~jojo/Carth

9cfd60cb6faa421be7b9a6776455017d46fd08de — JoJo 1 year, 10 months ago e847ffe
Add `box` and `deref`

Heap allocation and pointer dereferencing. Required for recursive
datatypes like lists.
M src/AnnotAst.hs => src/AnnotAst.hs +2 -0
@@ 59,6 59,8 @@ data Expr'
    | Match Expr DecisionTree Type
    | FunMatch DecisionTree Type Type
    | Ctor VariantIx TConst [Type]
    | Box Expr
    | Deref Expr
    deriving (Show)

type Expr = WithPos Expr'

M src/Ast.hs => src/Ast.hs +6 -0
@@ 103,6 103,8 @@ data Expr'
    | Match Expr (NonEmpty (Pat, Expr))
    | FunMatch (NonEmpty (Pat, Expr))
    | Ctor (Id Big)
    | Box Expr
    | Deref Expr
    deriving (Show, Eq)

type Expr = WithPos Expr'


@@ 181,6 183,8 @@ fvExpr = unpos >>> \case
    Match e cs -> fvMatch e (fromList1 cs)
    FunMatch cs -> fvCases (fromList1 cs)
    Ctor _ -> Set.empty
    Box e -> fvExpr e
    Deref e -> fvExpr e

fvMatch :: Expr -> [(Pat, Expr)] -> Set (Id Small)
fvMatch e cs = Set.union (freeVars e) (fvCases cs)


@@ 286,6 290,8 @@ prettyExpr' d = \case
        , ")"
        ]
    Ctor c -> pretty c
    Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]

prettyPat :: Pat -> String
prettyPat = \case

M src/Check.hs => src/Check.hs +2 -0
@@ 177,6 177,8 @@ checkTypeVarsBound (main, ds) = runReaderT
        An.Ctor _ (_, instTs) ts -> do
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        An.Box e -> boundInExpr e
        An.Deref e -> boundInExpr e
    boundInType :: SrcPos -> An.Type -> Bound
    boundInType pos = \case
        TVar tv ->

M src/Codegen.hs => src/Codegen.hs +10 -0
@@ 300,6 300,8 @@ genExpr = \case
    Let ds b -> genLet ds b
    Match e cs tbody -> genMatch e cs (toLlvmType tbody)
    Ction c -> genCtion c
    Box e -> genBox =<< genExpr e
    Deref e -> emitAnon . load =<< genExpr e

toLlvmDataType :: MonoAst.TConst -> Type
toLlvmDataType = typeNamed . mangleTConst


@@ 555,6 557,14 @@ genBoxGeneric x = do
    emit (store x ptr)
    pure ptrGeneric

genBox :: Operand -> Gen Operand
genBox x = do
    let t = typeOf x
    ptrGeneric <- genHeapAlloc =<< genSizeof t
    ptr <- emitAnon (bitcast ptrGeneric (LLType.ptr t))
    emit (store x ptr)
    pure ptr

genHeapAlloc :: Operand -> Gen Operand
genHeapAlloc size =
    emitAnon (callExtern "carth_alloc" (LLType.ptr typeUnit) [size])

M src/Desugar.hs => src/Desugar.hs +2 -0
@@ 36,6 36,8 @@ unsugarExpr (WithPos _ e) = case e of
            (\(p, pt) (bt, b) -> (TFun pt bt, Fun (p, pt) (b, bt)))
            (TConst inst, Ction v inst args)
            params
    An.Box e -> Box (unsugarExpr e)
    An.Deref e -> Deref (unsugarExpr e)

unsugarDecTree :: An.DecisionTree -> DecisionTree
unsugarDecTree = \case

M src/DesugaredAst.hs => src/DesugaredAst.hs +2 -0
@@ 50,6 50,8 @@ data Expr
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | Ction VariantIx TConst [Expr]
    | Box Expr
    | Deref Expr
    deriving (Show)

type Defs = Map String (Scheme, Expr)

M src/Infer.hs => src/Infer.hs +7 -0
@@ 185,6 185,12 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        dt <- toDecisionTree' pos tpat cases'
        pure (TFun tpat tbody, FunMatch dt tpat tbody)
    Ast.Ctor c -> inferExprConstructor c
    Ast.Box e -> fmap (\(te, e') -> (TBox te, Box e')) (infer e)
    Ast.Deref e -> do
        t <- fresh
        (te, e') <- infer e
        unify (Expected (TBox t)) (Found (getPos e) te)
        pure (t, Deref e')

toDecisionTree' :: SrcPos -> Type -> [(SrcPos, Pat, Expr)] -> Infer DecisionTree
toDecisionTree' pos tpat cases = do


@@ 327,6 333,7 @@ unify'' = curry $ \case
    (TVar a, t) -> pure (Map.singleton a t)
    (t, TVar a) -> unify'' (TVar a) t
    (TFun t1 t2, TFun u1 u2) -> unifys [t1, t2] [u1, u2]
    (TBox t, TBox u) -> unify'' t u
    (t1, t2) -> throwError (UnificationFailed'' t1 t2)

unifys :: [Type] -> [Type] -> Except UnifyErr'' Subst

M src/Mono.hs => src/Mono.hs +3 -0
@@ 21,6 21,7 @@ import qualified DesugaredAst as An
import DesugaredAst (TVar(..), Scheme(..))
import MonoAst


data Env = Env
    { _defs :: Map String (Scheme, An.Expr)
    , _tvBinds :: Map TVar Type


@@ 65,6 66,8 @@ mono = \case
    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.Box x -> fmap Box (mono x)
    An.Deref x -> fmap Deref (mono x)

monoFun :: (String, An.Type) -> (An.Expr, An.Type) -> Mono Expr
monoFun (p, tp) (b, bt) = do

M src/MonoAst.hs => src/MonoAst.hs +4 -0
@@ 68,6 68,8 @@ data Expr
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | Ction Ction
    | Box Expr
    | Deref Expr
    deriving (Show)

newtype Defs = Defs (Map TypedVar Expr)


@@ 95,6 97,8 @@ fvExpr = \case
    Let (Defs bs) e -> fvLet (Map.keysSet bs, Map.elems bs) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e
    Deref e -> fvExpr e

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case

M src/Parse.hs => src/Parse.hs +12 -2
@@ 142,8 142,10 @@ ns_expr = withPos
    bool = do
        b <- (ns_reserved "true" $> True) <|> (ns_reserved "false" $> False)
        pure (Lit (Bool b))
    pexpr = ns_parens
        (choice [funMatch, match, if', fun, let', typeAscr, app])
    pexpr =
        ns_parens $ choice
            [funMatch, match, if', fun, let', typeAscr, box, deref, app]


eConstructor :: Parser Expr'
eConstructor = fmap Ctor ns_big'


@@ 220,6 222,12 @@ binding = parens (bindingTyped <|> bindingUntyped)
typeAscr :: Parser Expr'
typeAscr = reserved ":" *> liftA2 TypeAscr expr type_

box :: Parser Expr'
box = reserved "box" *> fmap Box expr

deref :: Parser Expr'
deref = reserved "deref" *> fmap Deref expr

scheme :: Parser (WithPos Scheme)
scheme = andSkipSpaceAfter ns_scheme



@@ 376,6 384,8 @@ reserveds =
    , "fun"
    , "let"
    , "type"
    , "box"
    , "deref"
    ]

otherChar :: Parser Char

M src/Subst.hs => src/Subst.hs +2 -0
@@ 32,6 32,8 @@ substExpr s (WithPos p e) = WithPos p $ case e of
    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)
    Box e -> Box (substExpr s e)
    Deref e -> Deref (substExpr s e)

substDecisionTree :: Subst -> DecisionTree -> DecisionTree
substDecisionTree s = \case