~jojo/Carth

57d1b9670d589f917821c48136f08133e8c52791 — JoJo a month ago 0463c9a
add captureFreeLocalVars & unpackCaptures
2 files changed, 92 insertions(+), 45 deletions(-)

M src/Back/Low.hs
M src/Back/Lower.hs
M src/Back/Low.hs => src/Back/Low.hs +9 -1
@@ 105,6 105,7 @@ data Expr'
    -- Given a pointer to an untagged union, get it as a specific variant
    | EAsVariant Operand Word
    | EBranch (Branch Expr)
    | Bitcast Operand Type
    deriving Show

data Expr = Expr


@@ 123,7 124,14 @@ type VarNames = Vector String

type Allocs = [(LocalId, Type)]

data FunDef = FunDef GlobalId [Param LocalId] Ret (Block Terminator) Allocs VarNames
data FunDef = FunDef
    { funDefName :: GlobalId
    , funDefParams :: [Param LocalId]
    , funDefRet :: Ret
    , funDefBody :: Block Terminator
    , funDefAllocs :: Allocs
    , funDefLocalNames :: VarNames
    }
    deriving Show
data ExternDecl = ExternDecl String [Param ()] Ret
    deriving Show

M src/Back/Lower.hs => src/Back/Lower.hs +83 -44
@@ 18,6 18,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as Vec


@@ 46,6 47,7 @@ mapSizedM f = \case
data St = St
    { _strLits :: Map String Low.GlobalId
    , _localNames :: Vector String
    , _globalNames :: Vector String
    -- Iff a TConst is zero sized, it will have no entry
    , _tconsts :: Map TConst Low.TypeId
    , _tids :: Seq Low.TypeDef -- ^ Maps type IDs as indices to type defs


@@ 135,7 137,7 @@ lower noGC (Program (Topo defs) datas externs) =
        (externs'', fs, gs, tenv) = run $ do
            defineDatas
            externs' <- lowerExterns
            fs' <- mapM lowerFunDef funDefs
            fs' <- mapM (uncurry (lowerFunDef []) . bimap tvName snd) funDefs
            init <- defineInit
            tell (fs' ++ [init], [])
            pure externs'


@@ 171,9 173,11 @@ lower noGC (Program (Topo defs) datas externs) =
        --         forM_ ds genDefineGlobVar *> commitFinalFuncBlock retVoid $> LLType.void
        -- fmap (uncurry ((:) . GlobalDefinition)) $ genFunDef (name, [], param, genDefs)

    lowerFunDef :: (TypedVar, (Inst, Fun)) -> Lower Low.FunDef
    lowerFunDef (lhs, (_inst, (ps, (body, rt)))) = do
        let self@(Low.Global name _) = globFunEnv Map.! lhs
    lowerFunDef :: [TypedVar] -> String -> Fun -> Lower Low.FunDef
    lowerFunDef freeLocalVars sname (ps, (body, rt)) = locallySet localEnv Map.empty $ do
        -- Gotta remember these for when we return to whichever scope we came from
        oldLocalNames <- use localNames
        name <- newGName sname
        -- Zero-sized parameters don't actually get to exist in the Low IR and beyond
        (binds, innerParamIds, directParamTs) <-
            fmap (unzip3 . catMaybes) $ forM ps $ \p -> lowerType (tvType p) >>= \case


@@ 191,6 195,7 @@ lower noGC (Program (Topo defs) datas externs) =
            )
            directParamTs
        let innerParams = zipWith Low.Local innerParamIds paramTs
        Low.Block capturesStms capturesBinds <- unpackCaptures capturesName freeLocalVars
        -- Lower the body, generate an out-parameter if the return value is to be passed
        -- on the stack, and optimize to loop if the function is tail recursive.
        (outParam, outerParamIds, body'') <- do


@@ 198,14 203,14 @@ lower noGC (Program (Topo defs) datas externs) =
            -- case, the inner params and the outer params are the same.
            outerParamIds <- mapM spinoffLocalId innerParamIds
            let outerParams = zipWith Low.Local outerParamIds paramTs
            withVars binds $ case rt' of
            withVars (capturesBinds ++ binds) $ case rt' of
                ZeroSized -> do
                    body' <- lowerExpr Nowhere body
                    pure $ if isTailRec_RetVoid self body'
                    pure $ if isTailRec_RetVoid name body'
                        then
                            ( Nothing
                            , outerParamIds
                            , tailCallOpt_RetVoid self outerParams innerParams body'
                            , tailCallOpt_RetVoid name outerParams innerParams body'
                            )
                        else (Nothing, innerParamIds, mapTerm (\() -> Low.TRetVoid) body')
                Sized t -> passByRef t >>= \case


@@ 214,11 219,11 @@ lower noGC (Program (Topo defs) datas externs) =
                        let outParamOp = Low.OLocal $ Low.Local outParamId (Low.TPtr t)
                        let outParam = Just $ Low.ByRef outParamId t
                        body' <- lowerExpr (There outParamOp) body
                        pure $ if isTailRec_RetVoid self body'
                        pure $ if isTailRec_RetVoid name body'
                            then
                                ( outParam
                                , outerParamIds
                                , tailCallOpt_RetVoid self outerParams innerParams body'
                                , tailCallOpt_RetVoid name outerParams innerParams body'
                                )
                            else
                                ( outParam


@@ 227,25 232,43 @@ lower noGC (Program (Topo defs) datas externs) =
                                )
                    False -> do
                        body' <- lowerExpr Here body
                        pure $ if isTailRec_RetVal self body'
                        pure $ if isTailRec_RetVal name body'
                            then
                                ( Nothing
                                , outerParamIds
                                , tailCallOpt_RetVal self outerParams innerParams body'
                                , tailCallOpt_RetVal name outerParams innerParams body'
                                )
                            else (Nothing, innerParamIds, mapTerm Low.TRetVal body')
        localNames <- popLocalNames
        let body''' = Low.Block capturesStms () `thenBlock` body''
        localNames' <- popLocalNames
        assign localNames oldLocalNames
        allocs <- popAllocs
        outerParams <- zipWithM sizedToParam outerParamIds directParamTs
        let params =
                maybe id (:) outParam $ Low.ByVal capturesName Low.VoidPtr : outerParams
        ret <- toRet rt'
        pure $ Low.FunDef name params ret body'' allocs localNames
        pure $ Low.FunDef name params ret body''' allocs localNames'

    unpackCaptures
        :: Low.LocalId -> [TypedVar] -> Lower (Low.Block [(TypedVar, Low.Operand)])
    unpackCaptures capturesName freeVars = typedVarsSizedTypes freeVars >>= \case
        [] -> pure (Low.Block [] [])
        vars -> do
            let capturesGeneric = Low.OLocal $ Low.Local capturesName Low.VoidPtr
            tcaptures <- defineStruct "captures" $ map (first tvName) vars
            captures <-
                let t = Low.TPtr tcaptures
                in  emitNamed "captures" (Low.Expr (Low.Bitcast capturesGeneric t) t)
            captures `bindrBlockM` \captures' -> catBlocks <$> mapM
                (\(i, (v@(TypedVar x _), t)) -> mapTerm (v, )
                    <$> emitNamed x (Low.Expr (Low.EGetMember i captures') (Low.TPtr t))
                )
                (zip [0 ..] vars)

    isTailRec_RetVoid self = go
      where
        go (Low.Block stms ()) = case last stms of
            Low.VoidCall (Low.OGlobal other) _ | other == self -> True
            Low.VoidCall (Low.OGlobal (Low.Global other _)) _ | other == self -> True
            Low.SBranch br -> goBranch br
            _ -> False
        goBranch = \case


@@ 255,7 278,7 @@ lower noGC (Program (Topo defs) datas externs) =
    isTailRec_RetVal self = go
      where
        go (Low.Block _ (Low.Expr e _)) = case e of
            Low.Call (Low.OGlobal other) _ | other == self -> True
            Low.Call (Low.OGlobal (Low.Global other _)) _ | other == self -> True
            Low.EBranch br -> goBranch br
            _ -> False
        goBranch = \case


@@ 269,7 292,7 @@ lower noGC (Program (Topo defs) datas externs) =
        in  Low.Block [Low.SLoop loop] Low.TRetVoid
      where
        goStm = \case
            Low.VoidCall (Low.OGlobal other) args | other == self ->
            Low.VoidCall (Low.OGlobal (Low.Global other _)) args | other == self ->
                Low.Block [] (Low.Continue args)
            Low.SBranch br -> goBranch br
            stm -> Low.Block [stm] (Low.Break ())


@@ 295,7 318,7 @@ lower noGC (Program (Topo defs) datas externs) =
        go (Low.Block stms (Low.Expr lastExpr _)) =
            let termBlock = goExpr lastExpr in Low.Block stms () `thenBlock` termBlock
        goExpr = \case
            Low.Call (Low.OGlobal other) args | other == self ->
            Low.Call (Low.OGlobal (Low.Global other _)) args | other == self ->
                Low.Block [] (Low.Continue args)
            Low.EBranch br -> goBranch br
            e -> Low.Block [] (Low.Break (Low.Expr e t))


@@ 363,29 386,14 @@ lower noGC (Program (Topo defs) datas externs) =
                                      ()
                        _ -> ice "Lower.lowerExpr If: conseq and alt not same Sized"
                )
        Fun (params, (body, tbody)) -> do
            let params' = Set.fromList params
            freeLocalVars <- view localEnv <&> \locals -> Set.toList
                (Set.intersection (Set.difference (freeVars body) params')
                                  (Map.keysSet locals)
                )
            tbody' <- lowerType tbody
            captures <- if null freeLocalVars
                then pure (Low.Block [] (Low.OConst (Low.Zero Low.VoidPtr)))
                else do
                    tcaptures <-
                        defineStruct "captures"
                        . mapMaybe sizedMaybe
                        =<< mapM (\(TypedVar x t) -> mapSized (x, ) <$> lowerType t)
                                 freeLocalVars
                    capturesSize <- sizeof tcaptures
                    captures' <- emitNamed "captures" =<< gcAlloc (litI64 capturesSize)
                    bindBlockM (populateCaptures freeLocalVars) captures'
        Fun f -> do
            (freeLocalVars, captures) <- captureFreeLocalVars f
            -- genLambda' p body (VLocal captures) fvXs
            fname <- newLName "fun"
            -- ft <- lowerType pt <&> \pt' -> closureFunType pt' bt
            -- fname <- newLName "fun"
            -- ft <- typedVarsToParams params >>= \ps -> closureFunType ps tbody'
            -- let f = Low.OGlobal $ Low.Global fname (Low.TPtr ft)
            -- scribe outFuncs [(fname, fvXs, p, genBody $> bt)]
            fdef <- lowerFunDef freeLocalVars "fun" f
            tell ([fdef], [])
            -- genStruct [captures, f]
            undefined
        -- Let Def Expr


@@ 400,6 408,34 @@ lower noGC (Program (Topo defs) datas externs) =
        Absurd _ -> toDest dest ZeroSized
        _ -> undefined

    captureFreeLocalVars (params, (body, _)) = do
        let params' = Set.fromList params
        freeLocalVars <- view localEnv <&> \locals -> Set.toList
            (Set.intersection (Set.difference (freeVars body) params')
                              (Map.keysSet locals)
            )
        (freeLocalVars, ) <$> if null freeLocalVars
            then pure (Low.Block [] (Low.OConst (Low.Zero Low.VoidPtr)))
            else do
                tcaptures <-
                    defineStruct "captures"
                    . map (first tvName)
                    =<< typedVarsSizedTypes freeLocalVars
                capturesSize <- sizeof tcaptures
                captures' <- emitNamed "captures" =<< gcAlloc (litI64 capturesSize)
                bindBlockM (populateCaptures freeLocalVars) captures'

    typedVarsToParams :: [TypedVar] -> Lower [Low.Param String]
    typedVarsToParams = undefined

    typedVarsSizedTypes :: [TypedVar] -> Lower [(TypedVar, Low.Type)]
    typedVarsSizedTypes = mapMaybeM $ \v@(TypedVar _ t) -> lowerType t <&> \case
        Sized t' -> Just (v, t')
        ZeroSized -> Nothing

    closureFunType :: [Low.Param _a] -> Sized Low.Type -> Lower Low.Type
    closureFunType = undefined

    gcAlloc :: Low.Operand -> Lower Low.Expr
    gcAlloc size = do
        let fname = if noGC then "malloc" else "GC_malloc"


@@ 579,12 615,6 @@ lower noGC (Program (Topo defs) datas externs) =
    lowerGVarDecl :: (TypedVar, (Inst, Expr)) -> Low.GlobDef
    lowerGVarDecl = undefined

    globFunEnv :: Map TypedVar Low.Global
    globFunEnv = undefined funDefs

    _globVarEnv :: Map TypedVar Low.Global
    _globVarEnv = undefined gvarDefs

    (funDefs, gvarDefs) =
        let defs' = defs >>= \case
                VarDef d -> [d]


@@ 694,6 724,9 @@ lower noGC (Program (Topo defs) datas externs) =
        ZeroSized -> Nothing
        Sized t -> Just t

    fromSized = \case
        ZeroSized -> ice "Lower.fromSized: was ZeroSized"
        Sized x -> x

    toParam :: name -> Sized Low.Type -> Lower (Maybe (Low.Param name))
    toParam name = \case


@@ 813,3 846,9 @@ newLName x = do
    localId <- Vec.length <$> use localNames
    modifying localNames (`Vec.snoc` x)
    pure (fromIntegral localId)

newGName :: String -> Lower Low.GlobalId
newGName x = do
    globalId <- Vec.length <$> use globalNames
    modifying globalNames (`Vec.snoc` x)
    pure (fromIntegral globalId)