~jojo/Carth

cccde5c7b4794be97abcf719aa154def75d049ca — JoJo 1 year, 10 months ago fa1fab1
Scale datatype tag size by n of variants. 1 variant => no tag

Types with only 1 variant have no tag. Types with <=2^n variants have
n-bit tag.
M foreign-core/src/lib.rs => foreign-core/src/lib.rs +6 -11
@@ 35,7 35,6 @@ impl<A, B> Closure<A, B> {

#[repr(C)]
pub struct Array<A> {
    _tag: u64,
    elems: *mut A,
    len: u64,
}


@@ 44,7 43,6 @@ impl<A> Array<A> {
    fn new(xs: Vec<A>) -> Array<A> {
        let len = xs.len() as u64;
        Array {
            _tag: 0,
            elems: Box::into_raw(xs.into_boxed_slice()) as *mut A,
            len,
        }


@@ 53,14 51,12 @@ impl<A> Array<A> {

#[repr(C)]
pub struct Str {
    _tag: u64,
    array: Array<u8>,
}

impl Str {
    fn new(s: String) -> Str {
        Str {
            _tag: 0,
            array: Array::new(s.into_bytes()),
        }
    }


@@ 68,7 64,6 @@ impl Str {

#[repr(C)]
pub struct Pair<A, B> {
    _tag: u64,
    fst: A,
    snd: B,
}


@@ 93,7 88,7 @@ def_carth_closure! {

def_carth_closure! {
    "-str-append", STR_APPEND, str_append;
    Pair<Str, Str>, Str; Pair { fst, snd, .. } => {
    Pair<Str, Str>, Str; Pair { fst, snd } => {
        let (s1, s2) = (from_carth_str(&fst), from_carth_str(&snd));
        Str::new(s1.to_string() + s2)
    }


@@ 101,7 96,7 @@ def_carth_closure! {

fn from_carth_str<'s>(s: &'s Str) -> &'s str {
    unsafe {
        let Array { elems, len, .. } = s.array;
        let Array { elems, len } = s.array;
        let slice = slice::from_raw_parts(elems, len as usize);
        str::from_utf8_unchecked(slice)
    }


@@ 109,22 104,22 @@ fn from_carth_str<'s>(s: &'s Str) -> &'s str {

def_carth_closure! {
    "add-int", ADD_INT, add_int;
    Pair<i64, i64>, i64; Pair { fst, snd, .. } => fst + snd
    Pair<i64, i64>, i64; Pair { fst, snd } => fst + snd
}

def_carth_closure! {
    "rem-int", REM_INT, rem_int;
    Pair<i64, i64>, i64; Pair { fst, snd, .. } => fst % snd
    Pair<i64, i64>, i64; Pair { fst, snd } => fst % snd
}

def_carth_closure! {
    "gt-int", GT_INT, gt_int;
    Pair<i64, i64>, bool; Pair { fst, snd, .. } => fst > snd
    Pair<i64, i64>, bool; Pair { fst, snd } => fst > snd
}

def_carth_closure! {
    "eq-int", EQ_INT, eq_int;
    Pair<i64, i64>, bool; Pair { fst, snd, .. } => fst == snd
    Pair<i64, i64>, bool; Pair { fst, snd } => fst == snd
}

def_carth_closure! {

M src/AnnotAst.hs => src/AnnotAst.hs +3 -3
@@ 39,10 39,10 @@ data TypedVar = TypedVar Id Type

type VariantIx = Word64

data Access = Obj | As Access [Type] | Sel Word32 Access
data Access = Obj | As Access Span [Type] | Sel Word32 Span Access
    deriving (Show, Eq, Ord)

type Span = Int
type Span = Integer

type VarBindings = Map TypedVar Access



@@ 60,7 60,7 @@ data Expr'
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | FunMatch DecisionTree Type Type
    | Ctor VariantIx TConst [Type]
    | Ctor VariantIx Span TConst [Type]
    | Box Expr
    | Deref Expr
    deriving (Show)

M src/Check.hs => src/Check.hs +4 -4
@@ 94,8 94,8 @@ checkTypeDef
checkTypeDef (Ast.TypeDef x' ps (Ast.ConstructorDefs cs)) = do
    let x = idstr x'
    let ps' = map TVExplicit ps
    let cs' = map (\(Id (WithPos p x), ts) -> (p, (x, ts))) cs
    let cSpan = length cs
    let cs' = map (\(Id (WithPos p y), ts) -> (p, (y, ts))) cs
    let cSpan = fromIntegral (length cs)
    cs''' <- foldM
        (\cs'' (i, (cx, cps)) -> if Map.member (idstr cx) cs''
            then throwError (ConflictingCtorDef cx)


@@ 117,7 117,7 @@ builtinConstructors'
    :: (String, [TVar], [(String, [Type])])
    -> Map String (VariantIx, (String, [TVar]), [Type], Span)
builtinConstructors' (x, ps, cs) =
    let cSpan = length cs
    let cSpan = fromIntegral (length cs)
    in
        foldl'
            (\csAcc (i, (cx, cps)) ->


@@ 172,7 172,7 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            boundInDecTree dt
            boundInType pos pt
            boundInType pos bt
        An.Ctor _ (_, instTs) ts -> do
        An.Ctor _ _ (_, instTs) ts -> do
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        An.Box x -> boundInExpr x

M src/Codegen.hs => src/Codegen.hs +47 -18
@@ 182,7 182,8 @@ defineDataTypes tds = do
    mfix $ \tds' ->
        fmap Map.fromList $ augment dataTypes tds' $ forM tds $ \(tc, vs) -> do
            let n = mkName (mangleTConst tc)
            ts <- mapM toLlvmVariantType vs
            let totVariants = length vs
            ts <- mapM (toLlvmVariantType (fromIntegral totVariants)) vs
            sizedTs <- mapM (\t -> fmap (\s -> (s, t)) (sizeof t)) ts
            let (_, tmax) = maximum sizedTs
            pure (n, tmax)


@@ 329,8 330,10 @@ genExpr expr = do
toLlvmDataType :: MonoAst.TConst -> Type
toLlvmDataType = typeNamed . mangleTConst

toLlvmVariantType :: [MonoAst.Type] -> Gen' Type
toLlvmVariantType = fmap (typeStruct . (i64 :)) . mapM toLlvmType'
toLlvmVariantType :: Span -> [MonoAst.Type] -> Gen' Type
toLlvmVariantType totVariants =
    fmap (typeStruct . maybe id ((:) . IntegerType) (tagBitWidth totVariants))
        . mapM toLlvmType'

toLlvmType :: MonoAst.Type -> Gen Type
toLlvmType = lift . toLlvmType'


@@ 404,8 407,8 @@ genConst = fmap (VLocal . ConstantOperand) . \case
        let ptrVal = LLConst.BitCast llArrayVal (LLType.ptr i8)
        let arrayVal = litStructOfType
                ("Array", [TPrim TNat8])
                [litI64 0, ptrVal, litU64 len]
        let strVal = litStructOfType ("Str", []) [litI64 0, arrayVal]
                [ptrVal, litU64 len]
        let strVal = litStructOfType ("Str", []) [arrayVal]
        pure strVal
    Bool b -> pure $ litBool b



@@ 516,12 519,14 @@ genDecisionSwitch
genDecisionSwitch selector cs def tbody selections = do
    let (variantIxs, variantDts) = unzip (Map.toAscList cs)
    variantLs <- mapM (newName . (++ "_") . ("variant_" ++) . show) variantIxs
    let dests = zip (map litU64 variantIxs) variantLs
    defaultL <- newName "default"
    nextL <- newName "next"
    (m, selections') <- select genAs genSub selector selections
    mVariantIx <- emitReg' "found_variant_ix" =<< extractvalue m [0]
    commitToNewBlock (switch mVariantIx defaultL dests) defaultL
    let ixBits = getIntBitWidth (typeOf mVariantIx)
    let litIxInt = LLConst.Int ixBits . fromIntegral
    let dests' = zip (map litIxInt variantIxs) variantLs
    commitToNewBlock (switch mVariantIx defaultL dests') defaultL
    v <- getLocal =<< genDecisionTree tbody def selections'
    let genCase l dt = do
            commitToNewBlock (br nextL) l


@@ 534,30 539,44 @@ genDecisionLeaf :: (MonoAst.VarBindings, Expr) -> Selections Operand -> Gen Val
genDecisionLeaf (bs, e) selections =
    flip withLocals (genExpr e) =<< selectVarBindings genAs genSub selections bs

genAs :: [MonoAst.Type] -> Operand -> Gen Operand
genAs ts matchee = do
    tvariant <- lift (toLlvmVariantType ts)
genAs :: Span -> [MonoAst.Type] -> Operand -> Gen Operand
genAs totVariants ts matchee = do
    tvariant <- lift (toLlvmVariantType totVariants ts)
    let tgeneric = typeOf matchee
    pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)
    emit (store matchee pGeneric)
    p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr tvariant))
    emitReg' "ction" (load p)

genSub :: Word32 -> Operand -> Gen Operand
genSub i matchee =
    emitReg' "submatchee" =<< extractvalue matchee (pure (i + 1))
genSub :: Span -> Word32 -> Operand -> Gen Operand
genSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0
    in emitReg' "submatchee" =<< extractvalue matchee (pure (tagOffset + i))

genCtion :: MonoAst.Ction -> Gen Val
genCtion (i, tdef, as) = do
genCtion (i, span', dataType, as) = do
    as' <- mapM genExpr as
    s <- getLocal =<< genStruct (VLocal (litU64' i) : as')
    let tag = maybe
            id
            ((:) . VLocal . ConstantOperand . flip LLConst.Int (fromIntegral i))
            (tagBitWidth span')
    s <- getLocal =<< genStruct (tag as')
    let t = typeOf s
    let tgeneric = toLlvmDataType tdef
    let tgeneric = toLlvmDataType dataType
    pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)
    p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr t))
    emit (store s p)
    pure (VVar pGeneric)

tagBitWidth :: Span -> Maybe Word32
tagBitWidth span'
    | span' <= 2 ^ (0 :: Integer) = Nothing
    | span' <= 2 ^ (8 :: Integer) = Just 8
    | span' <= 2 ^ (16 :: Integer) = Just 16
    | span' <= 2 ^ (32 :: Integer) = Just 32
    | span' <= 2 ^ (64 :: Integer) = Just 64
    | otherwise = ice $ "tagBitWidth: span' = " ++ show span'

-- TODO: Eta-conversion
-- | A lambda is a pair of a captured environment and a function.  The captured
--   environment must be on the heap, since the closure value needs to be of


@@ 814,9 833,14 @@ extractvalue struct is = fmap
    (WithRetType
        (ExtractValue { aggregate = struct, indices' = is, metadata = [] })
    )
    (getIndexed (typeOf struct) is)
    (getIndexed (typeOf struct) (map fromIntegral is))
  where
    getIndexed = foldlM (\t i -> fmap (!! fromIntegral i) (getMembers t))
    getIndexed = foldlM $ \t i -> getMembers t <&> \us -> if i < length us
        then us !! i
        else
            ice
            $ "extractvalue: index out of bounds: "
            ++ (show (typeOf struct) ++ ", " ++ show is)
    getMembers = \case
        NamedTypeReference x -> getMembers =<< lift (lookupDataType x)
        StructureType _ members -> pure members


@@ 919,6 943,11 @@ getPointee = \case
    LLType.PointerType t _ -> t
    t -> ice $ "Tried to get pointee of non-function type " ++ pretty t

getIntBitWidth :: Type -> Word32
getIntBitWidth = \case
    LLType.IntegerType w -> w
    t -> ice $ "Tried to get bit width of non-integer type " ++ pretty t

mangleName :: (String, [MonoAst.Type]) -> String
mangleName (x, us) = x ++ mangleInst us


M src/Desugar.hs => src/Desugar.hs +2 -2
@@ 27,14 27,14 @@ unsugarExpr (WithPos _ e) = case e of
    An.FunMatch dt pt bt ->
        let x = "#x"
        in Fun (x, pt) (Match (Var (TypedVar x pt)) (unsugarDecTree dt) bt, bt)
    An.Ctor v inst ts ->
    An.Ctor v span' inst ts ->
        let
            xs = map (\n -> "#x" ++ show n) (take (length ts) [0 :: Word ..])
            params = zip xs ts
            args = map (Var . uncurry TypedVar) params
        in snd $ foldr
            (\(p, pt) (bt, b) -> (TFun pt bt, Fun (p, pt) (b, bt)))
            (TConst inst, Ction v inst args)
            (TConst inst, Ction v span' inst args)
            params
    An.Box e -> Box (unsugarExpr e)
    An.Deref e -> Deref (unsugarExpr e)

M src/DesugaredAst.hs => src/DesugaredAst.hs +3 -1
@@ 7,6 7,7 @@ module DesugaredAst
    , TypedVar(..)
    , Const(..)
    , VariantIx
    , Span
    , Access(..)
    , VarBindings
    , DecisionTree(..)


@@ 29,6 30,7 @@ import AnnotAst
    , Scheme(..)
    , Const(..)
    , VariantIx
    , Span
    , Access(..)
    , startType
    )


@@ 51,7 53,7 @@ data Expr
    | Fun (String, Type) (Expr, Type)
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | Ction VariantIx TConst [Expr]
    | Ction VariantIx Span TConst [Expr]
    | Box Expr
    | Deref Expr
    deriving (Show)

M src/Infer.hs => src/Infer.hs +2 -2
@@ 273,10 273,10 @@ nonconflictingPatVarDefs = flip foldM Map.empty $ \acc ks ->

inferExprConstructor :: Id 'Big -> Infer (Type, Expr')
inferExprConstructor c = do
    (variantIx, tdefLhs, cParams, _) <- lookupEnvConstructor c
    (variantIx, tdefLhs, cParams, cSpan) <- lookupEnvConstructor c
    (tdefInst, cParams') <- instantiateConstructorOfTypeDef tdefLhs cParams
    let t = foldr TFun (TConst tdefInst) cParams'
    pure (t, Ctor variantIx tdefInst cParams')
    pure (t, Ctor variantIx cSpan tdefInst cParams')

instantiateConstructorOfTypeDef
    :: (String, [TVar]) -> [Type] -> Infer (TConst, [Type])

M src/Match.hs => src/Match.hs +3 -2
@@ 155,7 155,8 @@ match obj descr ctx work rhs rules = \case
                ((pargs, getoargs, getdargs) : work)

            getoargs :: [Access]
            getoargs = args (\i -> Sel i (As obj (argTs pcon)))
            getoargs =
                args (\i -> Sel i (span pcon) (As obj (span pcon) (argTs pcon)))

            getdargs :: [Descr]
            getdargs = case descr of


@@ 214,7 215,7 @@ staticMatch pcon = \case
        | otherwise -> No
    Neg cs
        | Set.member pcon cs -> No
        | span pcon == 1 + Set.size cs -> Yes
        | span pcon == 1 + fromIntegral (Set.size cs) -> Yes
    _ -> Maybe

addneg :: Con -> Descr -> Descr

M src/Mono.hs => src/Mono.hs +7 -6
@@ 66,7 66,7 @@ mono = \case
    An.Fun p b -> monoFun p b
    An.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    An.Match e cs tbody -> monoMatch e cs tbody
    An.Ction v inst as -> monoCtion v inst as
    An.Ction v span' inst as -> monoCtion v span' inst as
    An.Box x -> fmap Box (mono x)
    An.Deref x -> fmap Deref (mono x)



@@ 124,15 124,16 @@ monoDecisionTree = \case
monoAccess :: An.Access -> Mono Access
monoAccess = \case
    An.Obj -> pure Obj
    An.As a ts -> liftA2 As (monoAccess a) (mapM monotype ts)
    An.Sel i a -> fmap (Sel i) (monoAccess a)
    An.As a span' ts ->
        liftA3 As (monoAccess a) (pure span') (mapM monotype ts)
    An.Sel i span' a -> fmap (Sel i span') (monoAccess a)

monoCtion :: VariantIx -> An.TConst -> [An.Expr] -> Mono Expr
monoCtion i (tdefName, tdefArgs) as = do
monoCtion :: VariantIx -> Span -> An.TConst -> [An.Expr] -> Mono Expr
monoCtion i span' (tdefName, tdefArgs) as = do
    tdefArgs' <- mapM monotype tdefArgs
    let tdefInst = (tdefName, tdefArgs')
    as' <- mapM mono as
    pure (Ction (i, tdefInst, as'))
    pure (Ction (i, span', tdefInst, as'))

addDefInst :: String -> Type -> Mono ()
addDefInst x t1 = do

M src/MonoAst.hs => src/MonoAst.hs +5 -4
@@ 11,6 11,7 @@ module MonoAst
    , Const(..)
    , VariantIx
    , VariantTypes
    , Span
    , Access(..)
    , VarBindings
    , DecisionTree(..)


@@ 29,7 30,7 @@ import qualified Data.Set as Set
import Data.Set (Set)
import Data.Word

import DesugaredAst (VariantIx)
import DesugaredAst (VariantIx, Span)
import FreeVars
import Ast (Const(..), TPrim(..))



@@ 47,7 48,7 @@ data TypedVar = TypedVar String Type

type VariantTypes = [Type]

data Access = Obj | As Access [Type] | Sel Word32 Access
data Access = Obj | As Access Span [Type] | Sel Word32 Span Access
    deriving (Show, Eq, Ord)

type VarBindings = [(TypedVar, Access)]


@@ 57,7 58,7 @@ data DecisionTree
    | DSwitch Access (Map VariantIx DecisionTree) DecisionTree
    deriving Show

type Ction = (VariantIx, TConst, [Expr])
type Ction = (VariantIx, Span, TConst, [Expr])

data Expr
    = Lit Const


@@ 93,7 94,7 @@ fvExpr = \case
    Fun p (b, _) -> fvFun p b
    Let bs e -> fvLet (Map.keysSet bs, map snd (Map.elems bs)) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, as) -> Set.unions (map fvExpr as)
    Ction (_, _, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e
    Deref e -> fvExpr e


M src/Selections.hs => src/Selections.hs +8 -8
@@ 19,8 19,8 @@ newSelections x = Map.singleton Obj x

select
    :: (Show a, Monad m)
    => ([Type] -> a -> m a)
    -> (Word32 -> a -> m a)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> Access
    -> Selections a
    -> m (a, Selections a)


@@ 29,20 29,20 @@ select conv sub selector selections = case Map.lookup selector selections of
    Nothing -> do
        (a, selections') <- case selector of
            Obj -> ice "select: Obj not in selections"
            As x ts -> do
            As x span' ts -> do
                (a', s') <- select conv sub x selections
                a'' <- conv ts a'
                a'' <- conv span' ts a'
                pure (a'', s')
            Sel i x -> do
            Sel i span' x -> do
                (a', s') <- select conv sub x selections
                a'' <- sub i a'
                a'' <- sub span' i a'
                pure (a'', s')
        pure (a, Map.insert selector a selections')

selectVarBindings
    :: (Show a, Monad m)
    => ([Type] -> a -> m a)
    -> (Word32 -> a -> m a)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> Selections a
    -> VarBindings
    -> m [(TypedVar, a)]

M src/Subst.hs => src/Subst.hs +4 -3
@@ 31,7 31,8 @@ substExpr s (WithPos p e) = WithPos p $ case e of
        Match (substExpr s e) (substDecisionTree s dt) (subst s tbody)
    FunMatch dt tp tb ->
        FunMatch (substDecisionTree s dt) (subst s tp) (subst s tb)
    Ctor i (tx, tts) ps -> Ctor i (tx, map (subst s) tts) (map (subst s) ps)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Box e -> Box (substExpr s e)
    Deref e -> Deref (substExpr s e)



@@ 46,8 47,8 @@ substDecisionTree s = \case
substAccess :: Subst -> Access -> Access
substAccess s = \case
    Obj -> Obj
    As a ts -> As (substAccess s a) (map (subst s) ts)
    Sel i a -> Sel i (substAccess s a)
    As a span' ts -> As (substAccess s a) span' (map (subst s) ts)
    Sel i span' a -> Sel i span' (substAccess s a)

substPat :: Subst -> Pat -> Pat
substPat s = \case