~jojo/Carth

964845aa89f20fa1003ea938d1aa91cdfd3124be — JoJo 1 year, 11 months ago d93637f
Add type `TPtr`

Useful for FFI, and will probably serve as a building block for GC /
owned pointers later.
8 files changed, 43 insertions(+), 18 deletions(-)

M src/Ast.hs
M src/Check.hs
M src/Codegen.hs
M src/Match.hs
M src/Mono.hs
M src/MonoAst.hs
M src/Parse.hs
M src/Subst.hs
M src/Ast.hs => src/Ast.hs +2 -0
@@ 70,6 70,7 @@ data Type
    | TPrim TPrim
    | TConst TConst
    | TFun Type Type
    | TPtr Type
    deriving (Show, Eq, Ord)

data Scheme = Forall


@@ 311,6 312,7 @@ prettyType = \case
    Ast.TVar tv -> pretty tv
    Ast.TPrim c -> pretty c
    Ast.TFun a b -> prettyTFun a b
    Ast.TPtr t -> "(Ptr " ++ pretty t ++ ")"
    Ast.TConst (c, ts) -> case ts of
        [] -> c
        ts -> concat ["(", c, " ", spcPretty ts, ")"]

M src/Check.hs => src/Check.hs +1 -0
@@ 440,6 440,7 @@ ftv = \case
    TVar tv -> Set.singleton tv
    TPrim _ -> Set.empty
    TFun t1 t2 -> Set.union (ftv t1) (ftv t2)
    TPtr t -> ftv t
    TConst (_, ts) -> Set.unions (map ftv ts)

ftvEnv :: Env -> Set TVar

M src/Codegen.hs => src/Codegen.hs +2 -0
@@ 298,6 298,7 @@ toLlvmType = \case
        [ LLType.ptr typeUnit
        , LLType.ptr (typeClosureFun (toLlvmType a) (toLlvmType r))
        ]
    TPtr t -> LLType.ptr (toLlvmType t)
    TConst t -> typeNamed (mangleTConst t)

genConst :: MonoAst.Const -> Gen LLConst.Constant


@@ 802,6 803,7 @@ mangleType :: MonoAst.Type -> String
mangleType = \case
    TPrim c -> pretty c
    TFun p r -> mangleTConst ("->", [p, r])
    TPtr t -> mangleTConst ("*", [t])
    TConst tc -> mangleTConst tc

mangleTConst :: TConst -> String

M src/Match.hs => src/Match.hs +1 -0
@@ 110,6 110,7 @@ missingPat t descr = case t of
        vs <- views tdefs (fromJust . Map.lookup tx)
        missingPat' vs descr
    TFun _ _ -> pure "_"
    TPtr _ -> pure "_"

missingPat' :: [String] -> Descr -> Match String
missingPat' vs = \case

M src/Mono.hs => src/Mono.hs +31 -17
@@ 146,38 146,52 @@ bindTvs :: An.Type -> Type -> Map TVar Type
bindTvs a b = case (a, b) of
    (An.TVar v, t) -> Map.singleton v t
    (An.TFun p0 r0, TFun p1 r1) -> Map.union (bindTvs p0 p1) (bindTvs r0 r1)
    (An.TPtr t0, TPtr t1) -> bindTvs t0 t1
    (An.TPrim _, TPrim _) -> Map.empty
    (An.TConst (_, ts0), TConst (_, ts1)) ->
        Map.unions (zipWith bindTvs ts0 ts1)
    (An.TPrim _, _) -> err
    (An.TFun _ _, _) -> err
    (An.TPtr _, _) -> err
    (An.TConst _, _) -> err
    where err = ice $ "bindTvs: " ++ show a ++ ", " ++ show b

monotype :: An.Type -> Mono Type
monotype = lift . monotype'

monotype' :: An.Type -> Reader Env Type
monotype' = \case
monotype = \case
    An.TVar v -> views tvBinds (lookup' (ice (show v ++ " not in tvBinds")) v)
    An.TPrim c -> pure (TPrim c)
    An.TFun a b -> liftA2 TFun (monotype' a) (monotype' b)
    An.TConst (c, ts) -> fmap (curry TConst c) (mapM monotype' ts)
    An.TFun a b -> liftA2 TFun (monotype a) (monotype b)
    An.TPtr t -> fmap TPtr (monotype t)
    An.TConst (c, ts) -> do
        ts' <- mapM monotype ts
        let tdefInst = (c, ts')
        modifying tdefInsts (Set.insert tdefInst)
        pure (TConst tdefInst)

insertInst :: String -> Type -> Expr -> Mono ()
insertInst x t b = modifying defInsts (Map.adjust (Map.insert t b) x)

instTypeDefs :: An.TypeDefs -> Set TConst -> TypeDefs
instTypeDefs tdefs insts = map
    (\(x, ts) -> instTypeDef x ts (lookup' (ice "in instTypeDefs") x tdefs))
    (Set.toList insts)
  where
    instTypeDef x ts (tvs, vs) =
        let
            vs' = runReader
                (mapM (mapM monotype') vs)
                (Env Map.empty (Map.fromList (zip tvs ts)))
        in ((x, ts), vs')
-- insts :: Set TConst
instTypeDefs :: An.TypeDefs -> Mono TypeDefs
instTypeDefs tdefs = do
    insts <- uses tdefInsts Set.toList
    instTypeDefs' tdefs insts

instTypeDefs' :: An.TypeDefs -> [TConst] -> Mono TypeDefs
instTypeDefs' tdefs = \case
    [] -> pure []
    inst : insts -> do
        oldTdefInsts <- use tdefInsts
        tdef' <- instTypeDef tdefs inst
        newTdefInsts <- use tdefInsts
        let newInsts = Set.difference newTdefInsts oldTdefInsts
        tdefs' <- instTypeDefs' tdefs (Set.toList newInsts ++ insts)
        pure (tdef' : tdefs')
instTypeDef :: An.TypeDefs -> TConst -> Mono (TConst, [VariantTypes])
instTypeDef tdefs (x, ts) = do
    let (tvs, vs) = lookup' (ice "lookup' failed in instTypeDef") x tdefs
    vs' <- augment tvBinds (Map.fromList (zip tvs ts)) (mapM (mapM monotype) vs)
    pure ((x, ts), vs')

lookup' :: Ord k => v -> k -> Map k v -> v
lookup' = Map.findWithDefault

M src/MonoAst.hs => src/MonoAst.hs +1 -0
@@ 38,6 38,7 @@ type TConst = (String, [Type])
data Type
    = TPrim TPrim
    | TFun Type Type
    | TPtr Type
    | TConst TConst
    deriving (Show, Eq, Ord)


M src/Parse.hs => src/Parse.hs +4 -1
@@ 245,7 245,7 @@ ptype :: Parser Type
ptype = parens ptype'

ptype' :: Parser Type
ptype' = tfun <|> tapp
ptype' = tfun <|> tapp <|> tptr

tapp :: Parser Type
tapp = liftA2 (TConst .* (,)) big (some type_)


@@ 257,6 257,9 @@ tfun = do
    ts <- some type_
    pure (foldr1 TFun (t : ts))

tptr :: Parser Type
tptr = reserved "Ptr" *> fmap TPtr type_

ns_tprim :: Parser TPrim
ns_tprim = try $ do
    s <- ns_big

M src/Subst.hs => src/Subst.hs +1 -0
@@ 61,6 61,7 @@ subst s t = case t of
    TVar tv -> fromMaybe t (Map.lookup tv s)
    TPrim _ -> t
    TFun a b -> TFun (subst s a) (subst s b)
    TPtr a -> TPtr (subst s a)
    TConst (c, ts) -> TConst (c, (map (subst s) ts))

composeSubsts :: Subst -> Subst -> Subst