~jojo/Carth

2d3b422ccdd3e04f7501bbc16c0bff181bd373fc — JoJo 1 year, 6 months ago b55c376
Add `store` special form to write to `Box` pointer
M src/Check.hs => src/Check.hs +3 -0
@@ 183,6 183,7 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            forM_ ts (boundInType pos)
        Inferred.Box x -> boundInExpr x
        Inferred.Deref x -> boundInExpr x
        Inferred.Store x p -> boundInExpr x *> boundInExpr p
        Inferred.Transmute x t u ->
            boundInExpr x *> boundInType pos t *> boundInType pos u
    boundInType :: SrcPos -> Inferred.Type -> Bound


@@ 246,5 247,7 @@ compileDecisionTrees tdefs = compDefs
                params
        Inferred.Box x -> fmap Checked.Box (compExpr x)
        Inferred.Deref x -> fmap Checked.Deref (compExpr x)
        Inferred.Store x p ->
            liftA2 Checked.Store (compExpr x) (compExpr p)
        Inferred.Transmute x t u ->
            compExpr x <&> \x' -> Checked.Transmute pos x' t u

M src/Checked.hs => src/Checked.hs +1 -0
@@ 59,6 59,7 @@ data Expr'
    | Ction VariantIx Span TConst [Expr]
    | Box Expr
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)

M src/Codegen.hs => src/Codegen.hs +10 -1
@@ 3,7 3,7 @@
-- | Generation of LLVM IR code from our monomorphic AST.
module Codegen (codegen) where

import LLVM.AST hiding (args)
import LLVM.AST hiding (args, Store)
import LLVM.AST.Typed
import LLVM.AST.Type hiding (ptr)
import LLVM.AST.DataLayout


@@ 229,6 229,7 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Ction c -> genCtion c
        Box e -> genBox =<< genExpr e
        Deref e -> genDeref e
        Store x p -> genStore x p
        Absurd t -> fmap (VLocal . undef) (genType t)
        Transmute epos e t u -> genTransmute epos e t u



@@ 529,6 530,14 @@ genDeref e = genExpr e >>= \case
    VVar x -> fmap VVar (selDeref x)
    VLocal x -> pure (VVar x)

genStore :: Expr -> Expr -> Gen Val
genStore x p = do
    x' <- getLocal =<< genExpr x
    p' <- genExpr p
    p'' <- getLocal p'
    emitDo (store x' p'')
    pure p'

genTransmute :: SrcPos -> Expr -> M.Type -> M.Type -> Gen Val
genTransmute pos e t u = do
    t' <- genType t

M src/Infer.hs => src/Infer.hs +6 -0
@@ 234,6 234,12 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        (tx, x') <- infer x
        unify (Expected (TBox t)) (Found (getPos x) tx)
        pure (t, Deref x')
    Parsed.Store x p -> do
        (tx, x') <- infer x
        (tp, p') <- infer p
        unify (Expected (TBox tx)) (Found (getPos p) tp)
        pure (tp, Store x' p')

    Parsed.Transmute x ->
        fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)


M src/Inferred.hs => src/Inferred.hs +1 -0
@@ 99,6 99,7 @@ data Expr'
    | Ctor VariantIx Span TConst [Type]
    | Box Expr
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr Type Type
    deriving Show


M src/Monomorphic.hs => src/Monomorphic.hs +2 -0
@@ 66,6 66,7 @@ data Expr'
    | Ction Ction
    | Box Expr
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    | Transmute SrcPos Expr Type Type
    deriving (Show)


@@ 98,6 99,7 @@ fvExpr (Expr _ ex) = case ex of
    Ction (_, _, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Absurd _ -> Set.empty
    Transmute _ x _ _ -> fvExpr x


M src/Monomorphize.hs => src/Monomorphize.hs +1 -0
@@ 77,6 77,7 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
    Checked.Ction v span' inst as -> monoCtion v span' inst as
    Checked.Box x -> fmap Box (mono x)
    Checked.Deref x -> fmap Deref (mono x)
    Checked.Store x p -> liftA2 Store (mono x) (mono p)
    Checked.Absurd t -> fmap Absurd (monotype t)
    Checked.Transmute xpos x t u ->
        liftA3 (Transmute xpos) (mono x) (monotype t) (monotype u)

M src/Parse.hs => src/Parse.hs +15 -14
@@ 192,20 192,19 @@ expr' = choice [estr, var, num, eConstructor, pexpr]
    estr = fmap (Lit . Str) strlit
    eConstructor = fmap Ctor big'
    var = fmap Var small'
    pexpr =
        parens
            $ choice
                [ funMatch
                , match
                , if'
                , fun
                , let'
                , typeAscr
                , box
                , deref
                , transmute
                , app
                ]
    pexpr = parens $ choice
        [ funMatch
        , match
        , if'
        , fun
        , let'
        , typeAscr
        , box
        , deref
        , store
        , transmute
        , app
        ]
    funMatch = reserved "fmatch" *> fmap FunMatch cases
    match = reserved "match" *> liftA2 Match expr cases
    cases = many (parens (reserved "case" *> (liftA2 (,) pat expr)))


@@ 232,6 231,7 @@ expr' = choice [estr, var, num, eConstructor, pexpr]
    typeAscr = reserved ":" *> liftA2 TypeAscr expr type_
    box = reserved "box" *> fmap Box expr
    deref = reserved "deref" *> fmap Deref expr
    store = reserved "store" *> liftA2 Store expr expr
    transmute = reserved "transmute" *> fmap Transmute expr
    app = do
        rator <- expr


@@ 392,6 392,7 @@ reserveds =
    , "data"
    , "box"
    , "deref"
    , "store"
    , "transmute"
    , "import"
    , "case"

M src/Parsed.hs => src/Parsed.hs +2 -0
@@ 75,6 75,7 @@ data Expr'
    | Ctor (Id 'Big)
    | Box Expr
    | Deref Expr
    | Store Expr Expr
    | Transmute Expr
    deriving (Show, Eq)



@@ 132,6 133,7 @@ fvExpr = unpos >>> \case
    Ctor _ -> Set.empty
    Box e -> fvExpr e
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Transmute e -> fvExpr e

fvMatch :: Expr -> [(Pat, Expr)] -> Set (Id 'Small)

M src/Pretty.hs => src/Pretty.hs +4 -0
@@ 141,6 141,10 @@ prettyExpr' d = \case
    Parsed.Ctor c -> pretty c
    Parsed.Box e -> concat ["(box ", pretty' (d + 5) e, ")"]
    Parsed.Deref e -> concat ["(deref ", pretty' (d + 7) e, ")"]
    Parsed.Store x p -> concat
        [ "(store " ++ pretty' (d + 7) x
        , indent (d + 7) ++ pretty' (d + 7) p ++ ")"
        ]
    Parsed.Transmute e -> concat ["(transmute ", pretty' (d + 11) e, ")"]

prettyBracketPair :: (Pretty a, Pretty b) => Int -> (a, b) -> String

M src/Subst.hs => src/Subst.hs +1 -0
@@ 34,6 34,7 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Box e -> Box (substExpr s e)
    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)

substCases :: Subst -> Cases -> Cases

M std/iter.carth => std/iter.carth +9 -9
@@ 29,7 29,7 @@
                         (case None None)))))
    (Iter (fun (_) (skip-while' xs)))))

(define (for xs f) (fold (const f) Unit xs))
(define (for xs f) (foldl (const f) Unit xs))

(define (map f xs)
  (Iter (fun (_) (map-maybe (map-both f (map f)) (next xs)))))


@@ 38,12 38,12 @@
  (Iter (fun (_) (map-maybe (map-snd (filter pred))
                            (next (skip-while (<o not pred) xs))))))

(define: (fold f acc xs)
(define: (foldl f acc xs)
    (forall (acc x) (Fun (Fun acc x acc) acc (Iter x) acc))
  (let ((fold' (fun ((Pair acc xs))
                 (match (next xs)
                   (case (Some (Pair x xs'))
                         (fold' (Pair (f acc x) xs')))
                   (case None
                         acc)))))
    (fold' (Pair acc xs))))
  (let ((foldl' (fun ((Pair acc xs))
                  (match (next xs)
                    (case (Some (Pair x xs'))
                          (foldl' (Pair (f acc x) xs')))
                    (case None
                          acc)))))
    (foldl' (Pair acc xs))))

M std/std.carth => std/std.carth +2 -0
@@ 1,7 1,9 @@
(import iter)
(import list)
(import maybe)
(import either)
(import math)
(import memo)

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