~jojo/Carth

4771171a0e4c957c12bc50cffe4fbb6325e779e7 — JoJo 1 year, 5 months ago c46859b
Make deref and store builtin virtual functions as well
M src/Check.hs => src/Check.hs +0 -4
@@ 171,8 171,6 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            forM_ instTs (boundInType pos)
            forM_ ts (boundInType pos)
        Inferred.Sizeof _t -> pure ()
        Inferred.Deref x -> boundInExpr x
        Inferred.Store x p -> boundInExpr x *> boundInExpr p
    boundInType :: SrcPos -> Inferred.Type -> Bound
    boundInType pos = \case
        Inferred.TVar tv -> do


@@ 235,5 233,3 @@ compileDecisionTrees tdefs = compDefs
                    (Inferred.TConst inst, Checked.Ction v span' inst args)
                    params
        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 +0 -2
@@ 64,8 64,6 @@ data Expr'
    | Match Expr DecisionTree Type
    | Ction VariantIx Span TConst [Expr]
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    deriving (Show)


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

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


@@ 254,8 254,6 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Match e cs tbody -> genMatch e cs =<< genType tbody
        Ction c -> genCtion c
        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)

genExprLambda :: TypedVar -> (Expr, M.Type) -> Gen Val


@@ 477,9 475,6 @@ selSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0
    in  emitReg "submatchee" =<< extractvalue matchee (pure (tagOffset + i))

selDeref :: Operand -> Gen Operand
selDeref x = emitAnonReg (load x)

genCtion :: M.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    lookupEnum dataType & lift >>= \case


@@ 498,19 493,6 @@ genCtion (i, span', dataType, as) = do
            emitDo (store s p)
            pure (VVar pGeneric)

genDeref :: Expr -> Gen Val
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'

genStrEq :: Val -> Val -> Gen Val
genStrEq s1 s2 = do
    s1' <- getLocal s1

M src/Gen.hs => src/Gen.hs +23 -1
@@ 471,7 471,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
            genWrapInLambdas rt' [] (drop (length as) xts)
                $ \bes -> mapM lookupVar bes >>= \bs -> f (as ++ bs)
    let wrap1 (xt, rt, f) = wrap [xt] rt (\xs -> f (xs !! 0))
    let wrap2 (xt, rt, f) = wrap [xt, xt] rt (\xs -> f (xs !! 0) (xs !! 1))
    let wrap2 (x0t, x1t, rt, f) = wrap [x0t, x1t] rt (\xs -> f (xs !! 0) (xs !! 1))
    case g of
        "+" -> wrap2 $ arithm add add fadd t
        "-" -> wrap2 $ arithm sub sub fsub t


@@ 497,11 497,18 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
                Just p -> (a, genType b, \x -> genTransmute p x a b)
                Nothing -> ice "genAppBuiltinVirtual: transmute: srcPos is Nothing"
            _ -> noInst
        "deref" -> wrap1 $ case t of
            M.TFun a b -> (a, genType b, genDeref)
            _ -> noInst
        "store" -> wrap2 $ case t of
            M.TFun a (M.TFun b c) -> (a, b, genType c, genStore)
            _ -> noInst
        _ -> ice $ "genAppBuiltinVirtual: No builtin virtual function `" ++ g ++ "`"
  where
    arithm u s f = \case
        M.TFun a@(M.TPrim p) (M.TFun b c) | a == b && a == c ->
            ( a
            , a
            , genType a
            , \x y -> fmap VLocal . emitAnonReg =<< if isNat p
                then liftA2 u (getLocal x) (getLocal y)


@@ 513,6 520,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
    bitwise u s = \case
        M.TFun a@(M.TPrim p) (M.TFun b c) | a == b && a == c && (isInt p || isNat p) ->
            ( a
            , a
            , genType a
            , \x y -> fmap VLocal . emitAnonReg =<< if isNat p
                then liftA2 u (getLocal x) (getLocal y)


@@ 522,6 530,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
    rel u s f = \case
        M.TFun a@(M.TPrim p) (M.TFun b _) | a == b ->
            ( a
            , a
            , pure typeBool
            , \x y ->
                fmap VLocal . emitAnonReg . flip zext i8 =<< emitAnonReg =<< if isNat p


@@ 540,6 549,16 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
        if sa == sb
            then transmute a' b' x
            else throwError (TransmuteErr pos (a, sa) (b, sb))
    genDeref :: Val -> Gen Val
    genDeref = \case
        VVar x -> fmap VVar (selDeref x)
        VLocal x -> pure (VVar x)
    genStore :: Val -> Val -> Gen Val
    genStore x p = do
        x' <- getLocal x
        p' <- getLocal p
        emitDo (store x' p')
        pure p
    isNat = \case
        TNat8 -> True
        TNat16 -> True


@@ 555,6 574,9 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
    noInst =
        ice $ "No instance of builtin virtual function " ++ g ++ " for type " ++ pretty t

selDeref :: Operand -> Gen Operand
selDeref x = emitAnonReg (load x)

-- | Assumes that the from-type and to-type are of the same size.
transmute :: Type -> Type -> Val -> Gen Val
transmute t u x = case (t, u) of

M src/Infer.hs => src/Infer.hs +0 -10
@@ 217,16 217,6 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Parsed.FunMatch cases -> fmap (second FunMatch) (inferFunMatch cases)
    Parsed.Ctor c -> inferExprConstructor c
    Parsed.Sizeof t -> fmap ((TPrim TInt, ) . Sizeof) (checkType pos t)
    Parsed.Deref x -> do
        t <- fresh
        (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')

inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, FunMatch)
inferFunMatch cases = do

M src/Inferred.hs => src/Inferred.hs +4 -2
@@ 95,8 95,6 @@ data Expr'
    | FunMatch FunMatch
    | Ctor VariantIx Span TConst [Type]
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    deriving Show

type Expr = WithPos Expr'


@@ 158,6 156,10 @@ builtinVirtuals =
              , ("<", relScm)
              , ("<=", relScm)
              , ("transmute", Forall (Set.fromList [tva, tvb]) (TFun ta tb))
              , ("deref", Forall (Set.fromList [tva]) (TFun (TBox ta) ta))
              , ( "store"
                , Forall (Set.fromList [tva]) (TFun ta (TFun (TBox ta) (TBox ta)))
                )
              ]

defSigs :: Def -> [(String, Scheme)]

M src/Monomorphic.hs => src/Monomorphic.hs +0 -4
@@ 59,8 59,6 @@ data Expr'
    | Match Expr DecisionTree Type
    | Ction Ction
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    | Absurd Type
    deriving (Show)



@@ 101,8 99,6 @@ fvExpr' = \case
    Match e dt _ -> Set.union (freeVars e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map freeVars as)
    Sizeof _t -> Set.empty
    Deref e -> freeVars e
    Store x p -> Set.union (freeVars x) (freeVars p)
    Absurd _ -> Set.empty

fvDecisionTree :: DecisionTree -> Set TypedVar

M src/Monomorphize.hs => src/Monomorphize.hs +0 -2
@@ 102,8 102,6 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
    Checked.Match e cs tbody -> monoMatch e cs tbody
    Checked.Ction v span' inst as -> monoCtion v span' inst as
    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)

monoFun :: Checked.Fun -> Mono Fun

M src/Parse.hs => src/Parse.hs +1 -17
@@ 182,19 182,7 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
    eConstructor = fmap Ctor big
    var = fmap Var small
    pexpr = getSrcPos >>= \p -> parens $ choice
        [ funMatch
        , match
        , if'
        , fun
        , let1 p
        , let'
        , letrec
        , typeAscr
        , sizeof
        , deref
        , store
        , app
        ]
        [funMatch, match, if', fun, let1 p, let', letrec, typeAscr, sizeof, app]
    funMatch = reserved "fmatch" *> fmap FunMatch cases
    match = reserved "match" *> liftA2 Match expr cases
    cases = many (parens (reserved "case" *> (liftA2 (,) pat expr)))


@@ 244,8 232,6 @@ expr' = choice [var, estr, num, eConstructor, pexpr]
        pure (name, WithPos pos (Nothing, f))
    typeAscr = reserved ":" *> liftA2 TypeAscr expr type_
    sizeof = reserved "sizeof" *> fmap Sizeof type_
    deref = reserved "deref" *> fmap Deref expr
    store = reserved "store" *> liftA2 Store expr expr
    app = do
        rator <- expr
        rands <- some expr


@@ 400,8 386,6 @@ reserveds =
    , "letrec"
    , "data"
    , "sizeof"
    , "deref"
    , "store"
    , "import"
    , "case"
    , "id@"

M src/Parsed.hs => src/Parsed.hs +0 -4
@@ 76,8 76,6 @@ data Expr'
    | FunMatch [(Pat, Expr)]
    | Ctor (Id 'Big)
    | Sizeof Type
    | Deref Expr
    | Store Expr Expr
    deriving (Show, Eq)

type Expr = WithPos Expr'


@@ 135,8 133,6 @@ fvExpr = unpos >>> \case
    FunMatch cs -> fvCases cs
    Ctor _ -> Set.empty
    Sizeof _t -> Set.empty
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)

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

M src/Pretty.hs => src/Pretty.hs +0 -3
@@ 127,9 127,6 @@ prettyExpr' d = \case
        ]
    Parsed.Ctor c -> pretty c
    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, indent (d + 7) ++ pretty' (d + 7) p ++ ")"]

prettyDef :: Int -> Parsed.Def -> String
prettyDef d' = \case

M src/Subst.hs => src/Subst.hs +0 -2
@@ 34,8 34,6 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    FunMatch f -> FunMatch (substFunMatch s f)
    Ctor i span' (tx, tts) ps -> Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Sizeof t -> Sizeof (subst s t)
    Deref e -> Deref (substExpr s e)
    Store x p -> Store (substExpr s x) (substExpr s p)

substFunMatch :: Subst -> FunMatch -> FunMatch
substFunMatch s (cs, tp, tb) = ((substCases s cs), (subst s tp), (subst s tb))