~jojo/Carth

b4845f5cacdc19b2a885526f801397b05a289b7f — JoJo 1 year, 6 months ago 2c17209
Replace `box` special form with `sizeof`

The special forms `sizeof` + `store` can be used together with a call
to the function `GC_malloc` to implement `box` as a standard library
function.
M src/Check.hs => src/Check.hs +2 -2
@@ 193,7 193,7 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
        Inferred.Ctor _ _ (_, instTs) ts -> do
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        Inferred.Box x -> boundInExpr x
        Inferred.Sizeof _t -> pure ()
        Inferred.Deref x -> boundInExpr x
        Inferred.Store x p -> boundInExpr x *> boundInExpr p
        Inferred.Transmute x t u ->


@@ 257,7 257,7 @@ compileDecisionTrees tdefs = compDefs
                )
                (Inferred.TConst inst, Checked.Ction v span' inst args)
                params
        Inferred.Box x -> fmap Checked.Box (compExpr x)
        Inferred.Sizeof t -> pure (Checked.Sizeof t)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)
        Inferred.Store x p ->
            liftA2 Checked.Store (compExpr x) (compExpr p)

M src/Checked.hs => src/Checked.hs +1 -1
@@ 58,7 58,7 @@ data Expr'
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | Ction VariantIx Span TConst [Expr]
    | Box Expr
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Absurd Type

M src/Codegen.hs => src/Codegen.hs +2 -13
@@ 228,7 228,8 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Let ds b -> genLet ds b
        Match e cs tbody -> genMatch e cs =<< genType tbody
        Ction c -> genCtion c
        Box e -> genBox =<< genExpr e
        Sizeof t ->
            (VLocal . litI64 . fromIntegral) <$> ((lift . sizeof) =<< genType t)
        Deref e -> genDeref e
        Store x p -> genStore x p
        Absurd t -> fmap (VLocal . undef) (genType t)


@@ 514,18 515,6 @@ genCtion (i, span', dataType, as) = do
            emitDo (store s p)
            pure (VVar pGeneric)

genBox :: Val -> Gen Val
genBox = fmap fst . genBox'

genBox' :: Val -> Gen (Val, Val)
genBox' x = do
    let t = typeOf x
    ptrGeneric <- genHeapAllocGeneric t
    ptr <- emitAnonReg (bitcast ptrGeneric (LLType.ptr t))
    x' <- getLocal x
    emitDo (store x' ptr)
    pure (VLocal ptr, VLocal ptrGeneric)

genDeref :: Expr -> Gen Val
genDeref e = genExpr e >>= \case
    VVar x -> fmap VVar (selDeref x)

M src/Infer.hs => src/Infer.hs +2 -2
@@ 1,4 1,4 @@
{-# LANGUAGE LambdaCase, TemplateHaskell, DataKinds, FlexibleContexts #-}
{-# LANGUAGE LambdaCase, TemplateHaskell, DataKinds, FlexibleContexts, TupleSections #-}

module Infer (inferTopDefs, checkType', checkType'') where



@@ 218,7 218,7 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        pure (tbody, App f matchee' tbody)
    Parsed.FunMatch cases -> inferFunMatch cases
    Parsed.Ctor c -> inferExprConstructor c
    Parsed.Box x -> fmap (\(tx, x') -> (TBox tx, Box x')) (infer x)
    Parsed.Sizeof t -> fmap ((TPrim TInt, ) . Sizeof) (checkType pos t)
    Parsed.Deref x -> do
        t <- fresh
        (tx, x') <- infer x

M src/Inferred.hs => src/Inferred.hs +1 -1
@@ 100,7 100,7 @@ data Expr'
    | Let Defs Expr
    | FunMatch Cases Type Type
    | Ctor VariantIx Span TConst [Type]
    | Box Expr
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr Type Type

M src/Monomorphic.hs => src/Monomorphic.hs +2 -2
@@ 64,7 64,7 @@ data Expr'
    | Let Defs Expr
    | Match Expr DecisionTree Type
    | Ction Ction
    | Box Expr
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Absurd Type


@@ 97,7 97,7 @@ fvExpr (Expr _ ex) = case ex of
        fvLet (Set.fromList (map fst bs), map (snd . unpos) (map snd bs)) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e
    Sizeof _t -> Set.empty
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Absurd _ -> Set.empty

M src/Monomorphize.hs => src/Monomorphize.hs +1 -1
@@ 78,7 78,7 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
    Checked.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    Checked.Match e cs tbody -> monoMatch e cs tbody
    Checked.Ction v span' inst as -> monoCtion v span' inst as
    Checked.Box x -> fmap Box (mono x)
    Checked.Sizeof t -> fmap Sizeof (monotype t)
    Checked.Deref x -> fmap Deref (mono x)
    Checked.Store x p -> liftA2 Store (mono x) (mono p)
    Checked.Absurd t -> fmap Absurd (monotype t)

M src/Parse.hs => src/Parse.hs +3 -3
@@ 199,7 199,7 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
        , fun
        , let'
        , typeAscr
        , box
        , sizeof
        , deref
        , store
        , transmute


@@ 229,7 229,7 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
        let f = foldr (WithPos pos . FunMatch . pure .* (,)) b params
        pure (name, (WithPos pos (Nothing, f)))
    typeAscr = reserved ":" *> liftA2 TypeAscr expr type_
    box = reserved "box" *> fmap Box expr
    sizeof = reserved "sizeof" *> fmap Sizeof type_
    deref = reserved "deref" *> fmap Deref expr
    store = reserved "store" *> liftA2 Store expr expr
    transmute = reserved "transmute" *> fmap Transmute expr


@@ 395,7 395,7 @@ reserveds =
    , "fun"
    , "let"
    , "data"
    , "box"
    , "sizeof"
    , "deref"
    , "store"
    , "transmute"

M src/Parsed.hs => src/Parsed.hs +3 -3
@@ 73,7 73,7 @@ data Expr'
    | Match Expr [(Pat, Expr)]
    | FunMatch [(Pat, Expr)]
    | Ctor (Id 'Big)
    | Box Expr
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr


@@ 127,11 127,11 @@ fvExpr = unpos >>> \case
    App f a -> fvApp f a
    If p c a -> fvIf p c a
    Let bs e -> fvLet (Set.fromList (map fst bs), map (snd . unpos . snd) bs) e
    TypeAscr e _ -> freeVars e
    TypeAscr e _t -> freeVars e
    Match e cs -> fvMatch e cs
    FunMatch cs -> fvCases cs
    Ctor _ -> Set.empty
    Box e -> fvExpr e
    Sizeof _t -> Set.empty
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Transmute e -> fvExpr e

M src/Pretty.hs => src/Pretty.hs +1 -1
@@ 139,7 139,7 @@ prettyExpr' d = \case
        , ")"
        ]
    Parsed.Ctor c -> pretty c
    Parsed.Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Parsed.Sizeof t -> concat ["(sizeof ", pretty' (d + 8) t, ")"]
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Store x p -> concat
        [ "(store " ++ pretty' (d + 7) x

M src/Subst.hs => src/Subst.hs +1 -1
@@ 32,7 32,7 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    FunMatch cs tp tb -> FunMatch (substCases s cs) (subst s tp) (subst s tb)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Box e -> Box (substExpr s e)
    Sizeof t -> Sizeof (subst s t)
    Deref e -> Deref (substExpr s e)
    Store x p -> Store (substExpr s x) (substExpr s p)
    Transmute e t u -> Transmute (substExpr s e) (subst s t) (subst s u)

A std/mem.carth => std/mem.carth +3 -0
@@ 0,0 1,3 @@
(define: (box x)
    (forall (a) (Fun a (Box a)))
  (store x (transmute (id@"GC_malloc" (sizeof a)))))

M std/std.carth => std/std.carth +1 -0
@@ 4,6 4,7 @@
(import either)
(import math)
(import memo)
(import mem)

(define (fst (Pair a _)) a)
(define (snd (Pair _ b)) b)