~jojo/Carth

0088875fe0b08bd1ddffe4c39c378884ae578550 — JoJo 1 year, 6 months ago a050b46
Fix some minor warnings
2 files changed, 13 insertions(+), 13 deletions(-)

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

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


@@ 195,7 195,7 @@ genFunDef (name, fvs, ptv@(TypedVar px pt), body) = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    ((rt, fParams), Out basicBlocks globStrings lambdaFuncs) <- runWriterT $ do
        (capturesParam, captureLocals) <- genExtractCaptures fvs
        (capturesParam, captureLocals) <- genExtractCaptures
        pt' <- genType pt
        px' <- newName px
        -- Load params according to calling convention


@@ 242,7 242,7 @@ genFunDef (name, fvs, ptv@(TypedVar px pt), body) = do
            str = litStructNamed' ("Str", []) [array]
            defStr = simpleGlobVar strName typeStr str
        pure [defInner, defStr]
    genExtractCaptures fvs = do
    genExtractCaptures = do
        capturesName <- newName "captures"
        let capturesPtrGenericType = LLType.ptr typeUnit
        let capturesPtrGeneric =


@@ 345,11 345,11 @@ app closure a rt = do
        (getFunRet (getPointee (typeOf f)))

genIf :: Expr -> Expr -> Expr -> Gen Val
genIf pred conseq alt = do
genIf pred' conseq alt = do
    conseqL <- newName "consequent"
    altL <- newName "alternative"
    nextL <- newName "next"
    predV <- emitAnon . flip trunc i1 =<< getLocal =<< genExpr pred
    predV <- emitAnon . flip trunc i1 =<< getLocal =<< genExpr pred'
    commitToNewBlock (condbr predV conseqL altL) conseqL
    conseqV <- getLocal =<< genExpr conseq
    fromConseqL <- use currentBlockLabel

M src/Mono.hs => src/Mono.hs +8 -8
@@ 24,7 24,7 @@ import MonoAst


data Env = Env
    { _defs :: Map String (Scheme, An.Expr)
    { _envDefs :: Map String (Scheme, An.Expr)
    , _tvBinds :: Map TVar Type
    }
makeLenses ''Env


@@ 52,7 52,7 @@ initInsts :: Insts
initInsts = Insts Map.empty Set.empty

initEnv :: Env
initEnv = Env { _defs = Map.empty, _tvBinds = Map.empty }
initEnv = Env { _envDefs = Map.empty, _tvBinds = Map.empty }

mono :: An.Expr -> Mono Expr
mono = \case


@@ 86,13 86,13 @@ monoLet ds body = do
    parentInsts <- uses defInsts (lookups ks)
    let newEmptyInsts = (fmap (const Map.empty) ds)
    modifying defInsts (Map.union newEmptyInsts)
    body' <- augment defs ds (mono body)
    body' <- augment envDefs ds (mono body)
    dsInsts <- uses defInsts (lookups ks)
    modifying defInsts (Map.union (Map.fromList parentInsts))
    let ds' = Map.fromList $ do
            (name, dInsts) <- dsInsts
            (t, (us, body)) <- Map.toList dInsts
            pure (TypedVar name t, (us, body))
            (t, (us, dbody)) <- Map.toList dInsts
            pure (TypedVar name t, (us, dbody))
    pure (ds', body')

monoMatch :: An.Expr -> An.DecisionTree -> An.Type -> Mono Expr


@@ 142,17 142,17 @@ addDefInst x t1 = do
        Nothing -> pure ()
        Just xInsts -> when (not (Map.member t1 xInsts)) $ do
            (Forall _ t2, body) <- views
                defs
                envDefs
                (lookup' (ice (x ++ " not in defs")) x)
            _ <- mfix $ \body' -> do
                -- The instantiation must be in the environment when
                -- monomorphizing the body, or we may infinitely recurse.
                let boundTvs = bindTvs t2 t1
                    instTs = Map.elems boundTvs
                insertInst x t1 (instTs, body')
                insertInst t1 (instTs, body')
                augment tvBinds boundTvs (mono body)
            pure ()
    where insertInst x t b = modifying defInsts (Map.adjust (Map.insert t b) x)
    where insertInst 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