~jojo/Carth

dceded572423e044ef689bcb7d2e54d6d428a236 — JoJo 1 year, 6 months ago a8e400e
Return void instead of {}. Allows for more tail call optimization

If a function returns {} (i.e. Unit), then

    %x = call {} @foo()
    ret {} %x

is automatically converted by LLVM to something like

   call {} @foo()
   ret {} zeroinitializer

This is a problem, as tail calls are only optimized if ["ret
immediately follows call and ret uses value of call or is
void"](http://llvm.org/docs/CodeGenerator.html#tail-call-optimization). Since
the value (%x) is no longer used after the conversion (zeroinitializer
instead), and {} is not void, the optimization doesn't happen. I
observe this in practice.

So to fix this issue, we either have to get LLVM to not do that stupid
conversion, or return void instead. One way to get LLVM not to do the
inversion would be to represent Unit as e.g. an i8. Then LLVM will be
forced to use %x, as it doesn't know that it's always zero. This
method would likely work, as I have observed that tail calls are
indeed optimized for functions returning integers. However, this would
make units sized, which seems like it would cause trouble or at least
prevent some optimizations.

So I went with the alternative: return void when the type is Unit or
any other single-variant enum. Luckily, not much code needed to be
changed (essentially, use genRetType instead of genType where
appropriate), but the solution is not differently typed, so I'll have
to be a bit careful.
3 files changed, 30 insertions(+), 19 deletions(-)

M src/Codegen.hs
M src/Extern.hs
M src/Gen.hs
M src/Codegen.hs => src/Codegen.hs +11 -10
@@ 185,7 185,7 @@ genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
        assign outerLambdaN 1
        let fName = mkName (name ++ "_func")
        (f, gs) <- genFunDef
            (fName, [], dpos, p, genTailExpr body *> genType rt)
            (fName, [], dpos, p, genTailExpr body *> genRetType rt)
        let fRef = LLConst.GlobalReference (LLType.ptr (typeOf f)) fName
        let capturesType = LLType.ptr typeUnit
        let captures = LLConst.Null capturesType


@@ 207,7 207,9 @@ genTailExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
            _ -> genExpr (Expr pos expr)

genTailReturn :: Val -> Gen ()
genTailReturn = (commitFinalFuncBlock . ret) <=< getLocal
genTailReturn v = if typeOf v == typeUnit
    then commitFinalFuncBlock retVoid
    else commitFinalFuncBlock . ret =<< getLocal v

genExpr :: Expr -> Gen Val
genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do


@@ 228,7 230,7 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
genExprLambda :: TypedVar -> (Expr, Monomorphic.Type) -> Gen Val
genExprLambda p (b, bt) = do
    let fvXs = Set.toList (Set.delete p (freeVars b))
    bt' <- genType bt
    bt' <- genRetType bt
    genLambda fvXs p (genTailExpr b, bt')

genConst :: Monomorphic.Const -> Gen Val


@@ 278,12 280,11 @@ app tailkind closure a = do
    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))
  where
    call' f as = WithRetType
        (callIntern tailkind f as)
        (getFunRet (getPointee (typeOf f)))
    let as = [(captures, []), (a', [])]
    let rt = getFunRet (getPointee (typeOf f))
    fmap VLocal $ if rt == LLType.void
        then emitDo (callIntern tailkind f as) $> litUnit
        else emitAnonReg $ WithRetType (callIntern tailkind f as) rt

genTailIf :: Expr -> Expr -> Expr -> Gen ()
genTailIf pred' conseq alt = do


@@ 337,7 338,7 @@ genLet' (Topo ds) genBody = do
                typeStruct
                (mapM (\(TypedVar _ t) -> genType t) fvXs)
            captures <- genHeapAllocGeneric tcaptures
            fbt' <- genType fbt
            fbt' <- genRetType fbt
            l <-
                getVar
                    =<< genLambda'

M src/Extern.hs => src/Extern.hs +11 -7
@@ 65,7 65,7 @@ genExtern (name, t, pos) = do
    ps <- forM pts' $ \pt' -> passByRef' pt' <&> \case
        True -> Parameter (LLType.ptr pt') anon [ByVal]
        False -> Parameter pt' anon []
    rt' <- genType' rt
    rt' <- genRetType' rt
    (rt'', ps') <- passByRef' rt' <&> \case
        True -> (LLType.void, Parameter (LLType.ptr rt') anon [SRet] : ps)
        False -> (rt', ps)


@@ 105,10 105,13 @@ genWrapper pos externName rt paramTs =
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType rt ats False)
                                    fname
                                call' = WithRetType
                                    (callExtern f as)
                                    (getFunRet (getPointee (typeOf f)))
                            in fmap VLocal (emitAnonReg call')
                            in
                                if rt == LLType.void
                                    then emitDo (callExtern f as)
                                        $> VLocal litUnit
                                    else fmap VLocal $ emitAnonReg $ WithRetType
                                        (callExtern f as)
                                        rt
            let
                genWrapper' fvs ps' = do
                    r <- getLocal =<< case ps' of


@@ 120,8 123,9 @@ genWrapper pos externName rt paramTs =
                                fvs
                                p
                                (genWrapper' (fvs ++ [p]) ps $> (), bt)
                    commitFinalFuncBlock (ret r)
                    pure (typeOf r)
                    if typeOf r == typeUnit
                        then commitFinalFuncBlock retVoid $> LLType.void
                        else commitFinalFuncBlock (ret r) $> typeOf r
            let wrapperName = "_wrapper_" ++ externName
            assign lambdaParentFunc (Just wrapperName)
            let fname = mkName (wrapperName ++ "_func")

M src/Gen.hs => src/Gen.hs +8 -2
@@ 505,6 505,12 @@ builtins = Map.fromList
    , ("install_stackoverflow_handler", ([], LLType.void))
    ]

genRetType :: Monomorphic.Type -> Gen Type
genRetType = lift . genRetType'

genRetType' :: Monomorphic.Type -> Gen' Type
genRetType' = fmap (\t -> if t == typeUnit then LLType.void else t) . genType'

genType :: Monomorphic.Type -> Gen Type
genType = lift . genType'



@@ 521,7 527,7 @@ genType' = \case
        Monomorphic.TInt32 -> i32
        Monomorphic.TInt -> i64
        Monomorphic.TF64 -> double
    Monomorphic.TFun a r -> liftA2 closureType (genType' a) (genType' r)
    Monomorphic.TFun a r -> liftA2 closureType (genType' a) (genRetType' r)
    Monomorphic.TBox t -> fmap LLType.ptr (genType' t)
    Monomorphic.TConst tc -> lookupEnum tc <&> \case
        Just 0 -> typeUnit


@@ 691,7 697,7 @@ tconstLookup = Map.lookup . mkName . mangleTConst

lookupDatatype :: Name -> Gen' Type
lookupDatatype x = view (enumTypes . to (Map.lookup x)) >>= \case
    Just 0 -> pure (typeUnit)
    Just 0 -> pure typeUnit
    Just w -> pure (IntegerType w)
    Nothing -> fmap
        (maybe (ice ("Undefined datatype " ++ show x)) typeStruct)