~jojo/Carth

65d26a121c86aeb7fc2cb9ffb2cef696bd9d832d — JoJo 1 year, 6 months ago 8b64ffa
Fix externs having fastcc & return differently when in tail pos

This is part of improving guarantees of tail call optimization. Still
a little bit to go.

I think the only remaining thing is to change {} to void, as it seems
LLVM doesn't like tail calls otherwise. If we return an int, it's all
good, but if we return unit, we get stack overflow.
4 files changed, 307 insertions(+), 152 deletions(-)

M src/Codegen.hs
M src/Compile.hs
M src/Extern.hs
M src/Gen.hs
M src/Codegen.hs => src/Codegen.hs +177 -85
@@ 163,11 163,11 @@ genMain = do
    assign currentBlockLabel (mkName "entry")
    assign currentBlockInstrs []
    Out basicBlocks _ _ _ <- execWriterT $ do
        emitDo' (callExtern "install_stackoverflow_handler" [])
        emitDo' (callBuiltin "install_stackoverflow_handler" [])
        f <- lookupVar (TypedVar "main" mainType)
        _ <- app f (VLocal litUnit)
        _ <- app Nothing f (VLocal litUnit)
        commitFinalFuncBlock (ret (litI32 0))
    pure (GlobalDefinition (simpleFunc (mkName "main") [] i32 basicBlocks []))
    pure (GlobalDefinition (externFunc (mkName "main") [] i32 basicBlocks []))

-- TODO: Change global defs to a new type that can be generated by llvm. As it
--       is now, global non-function variables can't be straight-forwardly


@@ 178,13 178,14 @@ genMain = do
genGlobDef
    :: (TypedVar, WithPos ([Monomorphic.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
    Fun p (body, _) -> do
    Fun p (body, rt) -> do
        let var = (v, ts)
        let name = mangleName var
        assign lambdaParentFunc (Just name)
        assign outerLambdaN 1
        let fName = mkName (name ++ "_func")
        (f, gs) <- genFunDef (fName, [], dpos, p, genExpr body)
        (f, gs) <- genFunDef
            (fName, [], dpos, p, genTailExpr body *> genType rt)
        let fRef = LLConst.GlobalReference (LLType.ptr (typeOf f)) fName
        let capturesType = LLType.ptr typeUnit
        let captures = LLConst.Null capturesType


@@ 193,6 194,21 @@ genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
        pure (GlobalDefinition closureDef : GlobalDefinition f : gs)
    _ -> nyi $ "Global non-function defs: " ++ show e

genTailExpr :: Expr -> Gen ()
genTailExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
    parent <- use lambdaParentFunc <* assign lambdaParentFunc Nothing
    case expr of
        App f e _ -> genTailApp f e
        If p c a -> genTailIf p c a
        Let ds b -> genTailLet ds b
        Match e cs tbody -> genTailMatch e cs =<< genType tbody
        _ -> genTailReturn =<< case expr of
            Fun p b -> assign lambdaParentFunc parent *> genExprLambda p b
            _ -> genExpr (Expr pos expr)

genTailReturn :: Val -> Gen ()
genTailReturn = (commitFinalFuncBlock . ret) <=< getLocal

genExpr :: Expr -> Gen Val
genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
    parent <- use lambdaParentFunc <* assign lambdaParentFunc Nothing


@@ 213,7 229,7 @@ genExprLambda :: TypedVar -> (Expr, Monomorphic.Type) -> Gen Val
genExprLambda p (b, bt) = do
    let fvXs = Set.toList (Set.delete p (freeVars b))
    bt' <- genType bt
    genLambda fvXs p (genExpr b, bt')
    genLambda fvXs p (genTailExpr b, bt')

genConst :: Monomorphic.Const -> Gen Val
genConst = \case


@@ 228,40 244,67 @@ genStrLit s = do
    pure $ VVar $ ConstantOperand
        (LLConst.GlobalReference (LLType.ptr typeStr) var)

-- | Beta-reduction and closure application
genTailApp :: Expr -> Expr -> Gen ()
genTailApp fe' ae' =
    genBetaReduceApp genTailExpr genTailReturn (app (Just Tail)) (fe', [ae'])

genApp :: Expr -> Expr -> Gen Val
genApp fe' ae' = genApp' (fe', [ae'])
  where
    -- TODO: Could/should the beta-reduction maybe happen in an earlier stage,
    --       like when desugaring?
    genApp' = \case
        (Expr _ (Fun p (b, _)), ae : aes) -> do
            a <- genExpr ae
            withVal p a (genApp' (b, aes))
        (Expr _ (App fe ae _), aes) -> genApp' (fe, ae : aes)
        (fe, []) -> genExpr fe
        (fe, aes) -> do
            closure <- genExpr fe
            as <- mapM genExpr aes
            foldlM (\f a -> app f a) closure as

app :: Val -> Val -> Gen Val
app closure a = do
genApp fe' ae' = genBetaReduceApp genExpr pure (app (Just NoTail)) (fe', [ae'])

-- | Beta-reduction and closure application
genBetaReduceApp
    :: (Expr -> Gen a)
    -> (Val -> Gen a)
    -> (Val -> Val -> Gen Val)
    -> (Expr, [Expr])
    -> Gen a
genBetaReduceApp genExpr' returnMethod app' = \case
    (Expr _ (Fun p (b, _)), ae : aes) -> do
        a <- genExpr ae
        withVal p a (genBetaReduceApp genExpr' returnMethod app' (b, aes))
    (Expr _ (App fe ae _), aes) ->
        genBetaReduceApp genExpr' returnMethod app' (fe, ae : aes)
    (fe, []) -> genExpr' fe
    (fe, aes) -> do
        f <- genExpr fe
        as <- mapM genExpr (init aes)
        closure <- foldlM (app (Just NoTail)) f as
        arg <- genExpr (last aes)
        returnMethod =<< app' closure arg

app :: Maybe TailCallKind -> Val -> Val -> Gen Val
app tailkind closure a = do
    closure' <- getLocal closure
    captures <- emitReg "captures" =<< extractvalue closure' [0]
    f <- emitReg "function" =<< extractvalue closure' [1]
    a' <- getLocal a
    let args = [(captures, []), (a', [])]
    fmap VLocal (emitAnonReg (call f args))
    fmap VLocal (emitAnonReg (call' f args))
  where
    call f as =
        WithRetType (callVoid f as) (getFunRet (getPointee (typeOf f)))
    call' f as = WithRetType
        (callIntern tailkind f as)
        (getFunRet (getPointee (typeOf f)))

genTailIf :: Expr -> Expr -> Expr -> Gen ()
genTailIf pred' conseq alt = do
    predV <- genExpr pred'
    genTailCondBr predV (genTailExpr conseq) (genTailExpr alt)

genIf :: Expr -> Expr -> Expr -> Gen Val
genIf pred' conseq alt = do
    predV <- genExpr pred'
    genCondBr predV (genExpr conseq) (genExpr alt)

genTailCondBr :: Val -> Gen () -> Gen () -> Gen ()
genTailCondBr predV genConseq genAlt = do
    predV' <- emitAnonReg . flip trunc i1 =<< getLocal predV
    conseqL <- newName "consequent"
    altL <- newName "alternative"
    commitToNewBlock (condbr predV' conseqL altL) conseqL
    genConseq
    assign currentBlockLabel altL
    genAlt

genCondBr :: Val -> Gen Val -> Gen Val -> Gen Val
genCondBr predV genConseq genAlt = do
    predV' <- emitAnonReg . flip trunc i1 =<< getLocal predV


@@ 277,8 320,14 @@ genCondBr predV genConseq genAlt = do
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi [(conseqV, fromConseqL), (altV, fromAltL)]))

genTailLet :: Defs -> Expr -> Gen ()
genTailLet ds = genLet' ds . genTailExpr

genLet :: Defs -> Expr -> Gen Val
genLet (Topo ds) letBody = do
genLet ds = genLet' ds . genExpr

genLet' :: Defs -> Gen a -> Gen a
genLet' (Topo ds) genBody = do
    -- For both function and variable bindings, we need separate the definition
    -- into two passes, where the first pre-allocates some stuff.
    (binds, cs) <- fmap unzip $ forM ds $ \case


@@ 291,7 340,11 @@ genLet (Topo ds) letBody = do
            fbt' <- genType fbt
            l <-
                getVar
                    =<< genLambda' p (genExpr fb, fbt') (VLocal captures) fvXs
                    =<< genLambda'
                            p
                            (genTailExpr fb, fbt')
                            (VLocal captures)
                            fvXs
            pure ((v, l), Left (captures, fvXs))
        (v@(TypedVar n t), WithPos _ (_, e)) -> do
            t' <- genType t


@@ 303,7 356,12 @@ genLet (Topo ds) letBody = do
            ((_, mem), Right e) -> do
                x <- getLocal =<< genExpr e
                emitDo (store x mem)
        genExpr letBody
        genBody

genTailMatch :: Expr -> DecisionTree -> Type -> Gen ()
genTailMatch m dt tbody = do
    m' <- getLocal =<< genExpr m
    genTailDecisionTree tbody dt (newSelections m')

genMatch :: Expr -> DecisionTree -> Type -> Gen Val
genMatch m dt tbody = do


@@ 312,71 370,105 @@ genMatch m dt tbody = do
    m' <- getLocal =<< genExpr m
    genDecisionTree tbody dt (newSelections m')

genTailDecisionTree :: Type -> DecisionTree -> Selections Operand -> Gen ()
genTailDecisionTree = genDecisionTree' genTailExpr genTailCondBr genTailCases

genDecisionTree :: Type -> DecisionTree -> Selections Operand -> Gen Val
genDecisionTree tbody = \case
    Monomorphic.DLeaf l -> genDecisionLeaf l
    Monomorphic.DSwitch selector cs def ->
        genDecisionSwitchIx selector cs def tbody
    Monomorphic.DSwitchStr selector cs def ->
        genDecisionSwitchStr selector cs def tbody

genDecisionSwitchIx
    :: Monomorphic.Access
    -> Map VariantIx DecisionTree
    -> DecisionTree
genDecisionTree = genDecisionTree' genExpr genCondBr genCases

genDecisionTree'
    :: (Expr -> Gen a)
    -> (Val -> Gen a -> Gen a -> Gen a)
    -> ( Type
       -> Selections Operand
       -> [Name]
       -> [DecisionTree]
       -> DecisionTree
       -> Gen a
       )
    -> Type
    -> DecisionTree
    -> Selections Operand
    -> Gen a
genDecisionTree' genExpr' genCondBr' genCases' tbody =
    let
        genDecisionLeaf (bs, e) selections = do
            bs' <- selectVarBindings selAs selSub selDeref selections bs
            withLocals bs' (genExpr' e)

        genDecisionSwitchIx selector cs def selections = do
            let (variantIxs, variantDts) = unzip (Map.toAscList cs)
            (m, selections') <- select selAs selSub selDeref selector selections
            mVariantIx <- case typeOf m of
                IntegerType _ -> pure m
                _ -> emitReg "found_variant_ix" =<< extractvalue m [0]
            let ixBits = getIntBitWidth (typeOf mVariantIx)
            let litIxInt = LLConst.Int ixBits
            variantLs <- mapM
                (newName . (++ "_") . ("variant_" ++) . show)
                variantIxs
            defaultL <- newName "default"
            let dests' = zip (map litIxInt variantIxs) variantLs
            commitToNewBlock (switch mVariantIx defaultL dests') defaultL
            genCases' tbody selections' variantLs variantDts def

        genDecisionSwitchStr selector cs def selections = do
            (matchee, selections') <- select
                selAs
                selSub
                selDeref
                selector
                selections
            let cs' = Map.toAscList cs
            let genCase (s, dt) next = do
                    s' <- genStrLit s
                    isMatch <- genStrEq (VLocal matchee) s'
                    -- Do some wrapping to preserve effect/Gen order
                    pure $ genCondBr' isMatch (genDT dt selections') next
            join (foldrM genCase (genDT def selections') cs')

        genDT = \case
            Monomorphic.DLeaf l -> genDecisionLeaf l
            Monomorphic.DSwitch selector cs def ->
                genDecisionSwitchIx selector cs def
            Monomorphic.DSwitchStr selector cs def ->
                genDecisionSwitchStr selector cs def
    in genDT

genTailCases
    :: Type
    -> Selections Operand
    -> [Name]
    -> [DecisionTree]
    -> DecisionTree
    -> Gen ()
genTailCases tbody selections variantLs variantDts def = do
    genTailDecisionTree tbody def selections
    forM_ (zip variantLs variantDts) $ \(l, dt) -> do
        assign currentBlockLabel l
        genTailDecisionTree tbody dt selections

genCases
    :: Type
    -> Selections Operand
    -> [Name]
    -> [DecisionTree]
    -> DecisionTree
    -> Gen Val
genDecisionSwitchIx selector cs def tbody selections = do
    let (variantIxs, variantDts) = unzip (Map.toAscList cs)
    variantLs <- mapM (newName . (++ "_") . ("variant_" ++) . show) variantIxs
    defaultL <- newName "default"
genCases tbody selections variantLs variantDts def = do
    nextL <- newName "next"
    (m, selections') <- select selAs selSub selDeref selector selections
    mVariantIx <- case typeOf m of
        IntegerType _ -> pure m
        _ -> emitReg "found_variant_ix" =<< extractvalue m [0]
    let ixBits = getIntBitWidth (typeOf mVariantIx)
    let litIxInt = LLConst.Int ixBits
    let dests' = zip (map litIxInt variantIxs) variantLs
    commitToNewBlock (switch mVariantIx defaultL dests') defaultL
    let genDecisionTree' dt = do
            u <- genDecisionTree tbody dt selections'
            liftA2 (,) (getLocal u) (use currentBlockLabel)
    v <- genDecisionTree' def
    let genDT dt = liftA2
            (,)
            (getLocal =<< genDecisionTree tbody dt selections)
            (use currentBlockLabel)
    v <- genDT def
    let genCase l dt = do
            commitToNewBlock (br nextL) l
            genDecisionTree' dt
            genDT dt
    vs <- zipWithM genCase variantLs variantDts
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi (v : vs)))

genDecisionSwitchStr
    :: Monomorphic.Access
    -> Map String DecisionTree
    -> DecisionTree
    -> Type
    -> Selections Operand
    -> Gen Val
genDecisionSwitchStr selector cs def tbody selections = do
    (matchee, selections') <- select selAs selSub selDeref selector selections
    let cs' = Map.toAscList cs
    let genCase :: (String, DecisionTree) -> Gen Val -> Gen (Gen Val)
        genCase (s, dt) next = do
            s' <- genStrLit s
            isMatch <- genStrEq (VLocal matchee) s'
            -- Do some wrapping to preserve effect/Gen order
            pure (genCondBr isMatch (genDT dt) next)
        genDT dt = genDecisionTree tbody dt selections'
    f <- foldrM genCase (genDT def) cs'
    f

genDecisionLeaf
    :: (Monomorphic.VarBindings, Expr) -> Selections Operand -> Gen Val
genDecisionLeaf (bs, e) selections = do
    bs' <- selectVarBindings selAs selSub selDeref selections bs
    withLocals bs' (genExpr e)

selAs :: Span -> [Monomorphic.Type] -> Operand -> Gen Operand
selAs totVariants ts matchee = do
    tvariant <- fmap typeStruct (lift (genVariantType totVariants ts))


@@ 436,5 528,5 @@ genStrEq :: Val -> Val -> Gen Val
genStrEq s1 s2 = do
    s1' <- getLocal s1
    s2' <- getLocal s2
    b <- emitAnonReg (callExtern "carth_str_eq" [s1', s2'])
    b <- emitAnonReg (callBuiltin "carth_str_eq" [s1', s2'])
    pure (VLocal b)

M src/Compile.hs => src/Compile.hs +24 -3
@@ 6,6 6,7 @@ module Compile (compile, run) where
import LLVM.Context
import LLVM.Module
import LLVM.Target
import LLVM.Target.Options
import LLVM.Analysis
import LLVM.OrcJIT
import LLVM.OrcJIT.CompileLayer as CL


@@ 58,7 59,7 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
    -- can optimize any tail call.
    let optLvl = if (getDebug cfg) then CodeGenOpt.Less else CodeGenOpt.Default
    in
        withHostTargetMachinePIC optLvl $ \tm -> do
        withMyTargetMachine optLvl $ \tm -> do
            layout <- getTargetMachineDataLayout tm
            verbose cfg ("   Generating LLVM")
            let amod = codegen layout file pgm


@@ 172,8 173,28 @@ writeLLVMAssemblyToFile' f m = do
    writeFile f ""
    writeLLVMAssemblyToFile (File f) m

withHostTargetMachinePIC :: CodeGenOpt.Level -> (TargetMachine -> IO a) -> IO a
withHostTargetMachinePIC = withHostTargetMachine Reloc.PIC CodeModel.Default
withMyTargetMachine :: CodeGenOpt.Level -> (TargetMachine -> IO a) -> IO a
withMyTargetMachine codeGenOpt f = do
    initializeAllTargets
    triple <- getProcessTargetTriple
    cpu <- getHostCPUName
    features <- getHostCPUFeatures
    (target, _) <- lookupTarget Nothing triple
    withTargetOptions $ \toptions -> do
        options <- peekTargetOptions toptions
        pokeTargetOptions
            (options { guaranteedTailCallOptimization = True })
            toptions
        withTargetMachine
            target
            triple
            cpu
            features
            toptions
            Reloc.PIC
            CodeModel.Default
            codeGenOpt
            f

optPasses :: CodeGenOpt.Level -> TargetMachine -> PassSetSpec
optPasses level tm =

M src/Extern.hs => src/Extern.hs +30 -21
@@ 28,7 28,7 @@ import LLVM.AST.ParameterAttribute
import qualified LLVM.AST.Constant as LLConst
import Control.Monad.Writer
import qualified Data.Map as Map
import Lens.Micro.Platform (view, to)
import Lens.Micro.Platform (view, to, assign)
import LLVM.AST.Typed
import qualified LLVM.AST.Type as LLType
import Data.Functor


@@ 69,7 69,7 @@ genExtern (name, t, pos) = do
    (rt'', ps') <- passByRef' rt' <&> \case
        True -> (LLType.void, Parameter (LLType.ptr rt') anon [SRet] : ps)
        False -> (rt', ps)
    let externDef = GlobalDefinition (simpleFunc (mkName name) ps' rt'' [] [])
    let externDef = GlobalDefinition (externFunc (mkName name) ps' rt'' [] [])
    wrapperDefs <- genWrapper pos name rt' pts
    pure (externDef : wrapperDefs)



@@ 98,33 98,42 @@ genWrapper pos externName rt paramTs =
                                        False
                                    )
                                    fname
                            emitDo $ callVoid f ((out, [SRet]) : as)
                            emitDo $ callExtern f ((out, [SRet]) : as)
                            pure (VVar out)
                        False ->
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType rt ats False)
                                    fname
                                call = WithRetType
                                    (callVoid f as)
                                call' = WithRetType
                                    (callExtern f as)
                                    (getFunRet (getPointee (typeOf f)))
                            in fmap VLocal (emitAnonReg call)
                            in fmap VLocal (emitAnonReg call')
            let
                genWrapper' fvs = \case
                    [] -> genCallExtern fvs
                    (p : ps) -> do
                        pts <- mapM (\(TypedVar _ t) -> genType t) ps
                        let bt = foldr closureType rt pts
                        genLambda fvs p (genWrapper' (fvs ++ [p]) ps, bt)
            let fname = mkName ("_wrapper_f_" ++ externName)
            (f, gs) <- locallySet srcPos (Just pos) $
                genFunDef
                    ( fname
                    , []
                    , pos
                    , firstParam
                    , genWrapper' [firstParam] restParams
                    )
                genWrapper' fvs ps' = do
                    r <- getLocal =<< case ps' of
                        [] -> genCallExtern fvs
                        (p : ps) -> do
                            pts <- mapM (\(TypedVar _ t) -> genType t) ps
                            let bt = foldr closureType rt pts
                            genLambda
                                fvs
                                p
                                (genWrapper' (fvs ++ [p]) ps $> (), bt)
                    commitFinalFuncBlock (ret r)
                    pure (typeOf r)
            let wrapperName = "_wrapper_" ++ externName
            assign lambdaParentFunc (Just wrapperName)
            let fname = mkName (wrapperName ++ "_func")
            (f, gs) <-
                locallySet srcPos (Just pos)
                    $ genFunDef
                        ( fname
                        , []
                        , pos
                        , firstParam
                        , genWrapper' [firstParam] restParams
                        )
            let fref = LLConst.GlobalReference (LLType.ptr (typeOf f)) fname
            let captures = LLConst.Null (LLType.ptr typeUnit)
            let closure = litStruct [captures, fref]

M src/Gen.hs => src/Gen.hs +76 -43
@@ 80,7 80,7 @@ type Gen' = StateT St (Reader Env)
data Out = Out
    { _outBlocks :: [BasicBlock]
    , _outStrings :: [(Name, String)]
    , _outFuncs :: [(Name, [TypedVar], SrcPos, TypedVar, Gen Val)]
    , _outFuncs :: [(Name, [TypedVar], SrcPos, TypedVar, Gen Type)]
    , _outSrcPos :: [(SrcPos, MetadataNodeID)]
    }



@@ 112,7 112,7 @@ instance Typed Val where
--   The signature definition, the parameter-loading, and the result return are
--   all done according to the calling convention.
genFunDef
    :: (Name, [TypedVar], SrcPos, TypedVar, Gen Val)
    :: (Name, [TypedVar], SrcPos, TypedVar, Gen Type)
    -> Gen' (Global, [Definition])
genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
    assign currentBlockLabel (mkName "entry")


@@ 126,12 126,9 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
            pt' <- genType pt
            px' <- newName px
            let pRef = LocalReference pt' px'
            result <- getLocal
                =<< withLocal ptv pRef (withLocals captureLocals genBody)
            let rt' = typeOf result
            rt' <- withLocal ptv pRef (withLocals captureLocals genBody)
            let fParams' =
                    [uncurry Parameter capturesParam [], Parameter pt' px' []]
            commitFinalFuncBlock (ret result)
            pure (rt', fParams')
    (funScopeMdId, funScopeMdDef) <- defineFunScopeMetadata
    ss <- mapM globStrVar globStrings


@@ 140,7 137,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
        (mapM (fmap (uncurry ((:) . GlobalDefinition)) . genFunDef) lambdaFuncs)
    ps <- mapM (defineSrcPos (MDRef funScopeMdId)) srcPoss
    let f =
            simpleFunc name fParams rt basicBlocks [("dbg", MDRef funScopeMdId)]
            internFunc name fParams rt basicBlocks [("dbg", MDRef funScopeMdId)]
    pure (f, concat ss ++ ls ++ (funScopeMdDef : ps))
  where
    globStrVar (strName, s) = do


@@ 246,7 243,7 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
--
--   Inside of the function, first all the captured variables are extracted from
--   the environment, then the body of the function is run.
genLambda :: [TypedVar] -> TypedVar -> (Gen Val, Type) -> Gen Val
genLambda :: [TypedVar] -> TypedVar -> (Gen (), Type) -> Gen Val
genLambda fvXs p body = do
    captures <- if null fvXs
        then pure (null' (LLType.ptr typeUnit))


@@ 265,7 262,7 @@ populateCaptures ptrGeneric fvXs = do
    ptr <- emitAnonReg (bitcast ptrGeneric (LLType.ptr (typeOf captures)))
    emitDo (store captures ptr)

genLambda' :: TypedVar -> (Gen Val, Type) -> Val -> [TypedVar] -> Gen Val
genLambda' :: TypedVar -> (Gen (), Type) -> Val -> [TypedVar] -> Gen Val
genLambda' p@(TypedVar _ pt) (b, bt) captures fvXs = do
    fname <- use lambdaParentFunc >>= \case
        Just s ->


@@ 277,7 274,7 @@ genLambda' p@(TypedVar _ pt) (b, bt) captures fvXs = do
            (LLType.ptr ft)
            fname
    pos <- view (srcPos . to (fromMaybe (ice "srcPos is Nothing in genLambda")))
    scribe outFuncs [(fname, fvXs, pos, p, b)]
    scribe outFuncs [(fname, fvXs, pos, p, b $> bt)]
    genStruct [captures, f]

compileUnitRef :: MDRef LLOp.DICompileUnit


@@ 307,33 304,45 @@ runGen' g = runReader (evalStateT g initSt) initEnv
        , _srcPosToMetadata = Map.empty
        }

callVoid
    :: Operand
    -> [(Operand, [LLVM.AST.ParameterAttribute.ParameterAttribute])]
    -> InstructionMetadata
    -> Instruction
callVoid f as meta = Call
    { tailCallKind = Nothing
    , callingConvention = LLCallConv.Fast
    , returnAttributes = []
    , function = Right f
    , arguments = as
    , functionAttributes = []
    , metadata = meta
internFunc
    :: Name
    -> [Parameter]
    -> Type
    -> [BasicBlock]
    -> [(ShortByteString, MDRef MDNode)]
    -> Global
internFunc n ps rt bs meta = Function
    { LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Hidden
    , LLGlob.dllStorageClass = Nothing
    , LLGlob.callingConvention = LLCallConv.Fast
    , LLGlob.returnAttributes = []
    , LLGlob.returnType = rt
    , LLGlob.name = n
    , LLGlob.parameters = (ps, False)
    , LLGlob.functionAttributes = []
    , LLGlob.section = Nothing
    , LLGlob.comdat = Nothing
    , LLGlob.alignment = 0
    , LLGlob.garbageCollectorName = Nothing
    , LLGlob.prefix = Nothing
    , LLGlob.basicBlocks = bs
    , LLGlob.personalityFunction = Nothing
    , LLGlob.metadata = meta
    }

simpleFunc
externFunc
    :: Name
    -> [Parameter]
    -> Type
    -> [BasicBlock]
    -> [(ShortByteString, MDRef MDNode)]
    -> Global
simpleFunc n ps rt bs meta = Function
externFunc n ps rt bs meta = Function
    { LLGlob.linkage = LLLink.External
    , LLGlob.visibility = LLVis.Default
    , LLGlob.dllStorageClass = Nothing
    , LLGlob.callingConvention = LLCallConv.Fast
    , LLGlob.callingConvention = LLCallConv.C
    , LLGlob.returnAttributes = []
    , LLGlob.returnType = rt
    , LLGlob.name = n


@@ 421,7 430,7 @@ genStruct xs = do
genHeapAllocGeneric :: Type -> Gen Operand
genHeapAllocGeneric t = do
    size <- fmap (litI64 . fromIntegral) (lift (sizeof t))
    emitAnonReg (callExtern "carth_alloc" [size])
    emitAnonReg (callBuiltin "carth_alloc" [size])

genStackAllocated :: Operand -> Gen Operand
genStackAllocated v = do


@@ 435,28 444,52 @@ lookupVar x = do
        Just var -> pure (VVar var)
        Nothing -> ice $ "Undefined variable " ++ show x

callExtern :: String -> [Operand] -> FunInstr
callExtern f as =
callBuiltin :: String -> [Operand] -> FunInstr
callBuiltin f as =
    let
        (_, tr) = fromMaybe
            (ice $ "callExtern on '" ++ f ++ "' not in builtins")
            (ice $ "callBuiltin on '" ++ f ++ "' not in builtins")
            (Map.lookup f builtins)
    in
        flip WithRetType tr $ \meta -> Call
            { tailCallKind = Nothing
            , callingConvention = LLCallConv.C
            , returnAttributes = []
            , function = Right $ ConstantOperand $ LLConst.GlobalReference
                (LLType.ptr (FunctionType tr (map typeOf as) False))
                (mkName f)
            , arguments = map (, []) as
            , functionAttributes = []
            , metadata = meta
            }
        f' = ConstantOperand $ LLConst.GlobalReference
            (LLType.ptr (FunctionType tr (map typeOf as) False))
            (mkName f)
    in flip WithRetType tr $ callExtern f' (map (, []) as)

callIntern
    :: Maybe TailCallKind
    -> Operand
    -> [(Operand, [LLVM.AST.ParameterAttribute.ParameterAttribute])]
    -> InstructionMetadata
    -> Instruction
callIntern = call LLCallConv.Fast

callExtern
    :: Operand
    -> [(Operand, [LLVM.AST.ParameterAttribute.ParameterAttribute])]
    -> InstructionMetadata
    -> Instruction
callExtern = call LLCallConv.C Nothing

call
    :: LLCallConv.CallingConvention
    -> Maybe TailCallKind
    -> Operand
    -> [(Operand, [LLVM.AST.ParameterAttribute.ParameterAttribute])]
    -> InstructionMetadata
    -> Instruction
call callconv tailkind f as meta = Call
    { tailCallKind = tailkind
    , callingConvention = callconv
    , returnAttributes = []
    , function = Right f
    , arguments = as
    , functionAttributes = []
    , metadata = meta
    }

genBuiltins :: [Definition]
genBuiltins = map
    (\(x, (ps, tr)) -> GlobalDefinition (simpleFunc (mkName x) ps tr [] []))
    (\(x, (ps, tr)) -> GlobalDefinition (externFunc (mkName x) ps tr [] []))
    (Map.toList builtins)

builtins :: Map String ([Parameter], Type)