~jojo/Carth

0b15c3c4de03ca481abb86ddf28db149b19d56d3 — JoJo 1 year, 10 months ago 5cf7441
Base name mangling on instantiation types instead of type

E.g. "id<Int>" instead of "Id<Fun<Int, Int>>"
3 files changed, 39 insertions(+), 36 deletions(-)

M src/Codegen.hs
M src/Mono.hs
M src/MonoAst.hs
M src/Codegen.hs => src/Codegen.hs +25 -20
@@ 140,9 140,9 @@ instance Typed Val where


codegen :: DataLayout -> FilePath -> Program -> EncodeAST Module
codegen layout moduleFilePath (Program main (Defs defs) tdefs externs) = do
codegen layout moduleFilePath (Program main defs tdefs externs) = do
    tdefs' <- defineDataTypes layout tdefs
    let defs' = (TypedVar "main" mainType, main) : Map.toList defs
    let defs' = (TypedVar "-main" mainType, ([], main)) : Map.toList defs
        genGlobDefs = withExternSigs externs $ withGlobDefSigs
            defs'
            (liftA2 (:) genOuterMain (fmap join (mapM genGlobDef defs')))


@@ 223,7 223,7 @@ genOuterMain = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ <- execWriterT $ do
        f <- lookupVar (TypedVar "main" mainType)
        f <- lookupVar (TypedVar "-main" mainType)
        _ <- app f (VLocal (ConstantOperand litUnit)) typeUnit
        commitFinalFuncBlock (ret (ConstantOperand (litI32 0)))
    pure (GlobalDefinition (simpleFunc (mkName "main") [] i32 basicBlocks))


@@ 234,15 234,16 @@ genOuterMain = do
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef :: (TypedVar, Expr) -> Gen' [Definition]
genGlobDef (v, e) = case e of
genGlobDef :: (TypedVar, ([MonoAst.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, (ts, e)) = case e of
    Fun p (body, _) ->
        fmap (map GlobalDefinition) (genClosureWrappedFunDef v p body)
        fmap (map GlobalDefinition) (genClosureWrappedFunDef (v, ts) p body)
    _ -> nyi $ "Global non-function defs: " ++ show e

genClosureWrappedFunDef :: TypedVar -> TypedVar -> Expr -> Gen' [Global]
genClosureWrappedFunDef
    :: (String, [MonoAst.Type]) -> TypedVar -> Expr -> Gen' [Global]
genClosureWrappedFunDef var p body = do
    let name = mangleName' var
    let name = mangleName var
    assign lambdaParentFunc (Just name)
    assign outerLambdaN 1
    let fName = mkName (name ++ "_func")


@@ 470,11 471,11 @@ genIf pred conseq alt = do
    fmap VLocal (emitAnon (phi [(conseqV, fromConseqL), (altV, fromAltL)]))

genLet :: Defs -> Expr -> Gen Val
genLet (Defs ds) b = do
genLet ds b = do
    let (vs, es) = unzip (Map.toList ds)
    ps <- mapM (\(TypedVar n t) -> emitReg' n (alloca (toLlvmType t))) vs
    withVars (zip vs ps) $ do
        forM_ (zip ps es) $ \(p, e) -> do
        forM_ (zip ps es) $ \(p, (_, e)) -> do
            x <- getLocal =<< genExpr e
            emit (store x p)
        genExpr b


@@ 681,12 682,16 @@ withExternSigs = augment env . Map.fromList . map
        )
    )

withGlobDefSigs :: MonadReader Env m => [(TypedVar, Expr)] -> m a -> m a
withGlobDefSigs
    :: MonadReader Env m => [(TypedVar, ([MonoAst.Type], Expr))] -> m a -> m a
withGlobDefSigs = augment env . Map.fromList . map
    (\(v@(TypedVar _ t), _) ->
    (\(v@(TypedVar x t), (us, _)) ->
        ( v
        , ConstantOperand
            (LLConst.GlobalReference (LLType.ptr (toLlvmType t)) (mangleName v))
            (LLConst.GlobalReference
                (LLType.ptr (toLlvmType t))
                (mkName (mangleName (x, us)))
            )
        )
    )



@@ 929,11 934,13 @@ getMembers = \case
getIndexed :: Type -> [Word32] -> Type
getIndexed = foldl' (\t i -> getMembers t !! (fromIntegral i))

mangleName :: TypedVar -> Name
mangleName = mkName . mangleName'
mangleName :: (String, [MonoAst.Type]) -> String
mangleName (x, us) = x ++ mangleInst us

mangleName' :: TypedVar -> String
mangleName' (TypedVar x t) = concat [x, "<", mangleType t, ">"]
mangleInst :: [MonoAst.Type] -> String
mangleInst ts = if not (null ts)
    then "<" ++ intercalate ", " (map mangleType ts) ++ ">"
    else ""

mangleType :: MonoAst.Type -> String
mangleType = \case


@@ 943,9 950,7 @@ mangleType = \case
    TConst tc -> mangleTConst tc

mangleTConst :: TConst -> String
mangleTConst (c, ts) = if null ts
    then c
    else concat [c, "<", intercalate ", " (map mangleType ts), ">"]
mangleTConst (c, ts) = c ++ mangleInst ts

sizeof :: DataLayout -> Type -> EncodeAST Word64
sizeof layout t = do

M src/Mono.hs => src/Mono.hs +11 -10
@@ 1,5 1,6 @@
{-# LANGUAGE TemplateHaskell, LambdaCase, TupleSections
           , TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}
           , TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses
           , FlexibleContexts#-}

-- | Monomorphization
module Mono (monomorphize) where


@@ 29,7 30,7 @@ data Env = Env
makeLenses ''Env

data Insts = Insts
    { _defInsts :: Map String (Map Type Expr)
    { _defInsts :: Map String (Map Type ([Type], Expr))
    , _tdefInsts :: Set TConst
    }
makeLenses ''Insts


@@ 90,9 91,9 @@ monoLet ds body = do
    modifying defInsts (Map.union (Map.fromList parentInsts))
    let ds' = Map.fromList $ do
            (name, dInsts) <- dsInsts
            (t, body) <- Map.toList dInsts
            pure (TypedVar name t, body)
    pure (Defs ds', body')
            (t, (us, body)) <- Map.toList dInsts
            pure (TypedVar name t, (us, body))
    pure (ds', body')

monoMatch :: An.Expr -> An.DecisionTree -> An.Type -> Mono Expr
monoMatch e dt tbody =


@@ 145,9 146,12 @@ addDefInst x t1 = do
            _ <- mfix $ \body' -> do
                -- The instantiation must be in the environment when
                -- monomorphizing the body, or we may infinitely recurse.
                insertInst x t1 body'
                augment tvBinds (bindTvs t2 t1) (mono body)
                let boundTvs = bindTvs t2 t1
                    instTs = Map.elems boundTvs
                insertInst x t1 (instTs, body')
                augment tvBinds boundTvs (mono body)
            pure ()
    where insertInst x t b = modifying defInsts (Map.adjust (Map.insert t b) x)

bindTvs :: An.Type -> Type -> Map TVar Type
bindTvs a b = case (a, b) of


@@ 175,9 179,6 @@ monotype = \case
        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 -> Mono TypeDefs
instTypeDefs tdefs = do
    insts <- uses tdefInsts Set.toList

M src/MonoAst.hs => src/MonoAst.hs +3 -6
@@ 16,7 16,7 @@ module MonoAst
    , DecisionTree(..)
    , Ction
    , Expr(..)
    , Defs(..)
    , Defs
    , TypeDefs
    , Program(..)
    , mainType


@@ 72,11 72,8 @@ data Expr
    | Deref Expr
    deriving (Show)

newtype Defs = Defs (Map TypedVar Expr)
    deriving (Show)

type Defs = Map TypedVar ([Type], Expr)
type TypeDefs = [(TConst, [VariantTypes])]

type Externs = [(String, Type)]

data Program = Program Expr Defs TypeDefs Externs


@@ 94,7 91,7 @@ fvExpr = \case
    App f a _ -> fvApp f a
    If p c a -> fvIf p c a
    Fun p (b, _) -> fvFun p b
    Let (Defs bs) e -> fvLet (Map.keysSet bs, Map.elems bs) e
    Let bs e -> fvLet (Map.keysSet bs, map snd (Map.elems bs)) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, as) -> Set.unions (map fvExpr as)
    Box e -> fvExpr e