~jojo/Carth

a0ea5e62a7d74b1bf1d49d73aaeed3a2ff37b491 — JoJo 29 days ago 33b8e29
lower: impl run, fix lowerExpr App, & fix some call conv stuff
3 files changed, 139 insertions(+), 104 deletions(-)

M src/Back/Low.hs
M src/Back/Lower.hs
M src/Misc.hs
M src/Back/Low.hs => src/Back/Low.hs +5 -0
@@ 35,6 35,10 @@ data Type
    | TFun [Param ()] Ret
    | TConst TypeId
    | TArray Type Word
    -- Closures are represented as a builtin struct named "closure", with a generic
    -- pointer to captures and a void-pointer representing the function. During lowering,
    -- we still need to remember the "real" type of the function.
    | TClosure [Param ()] Ret
  deriving (Eq, Ord, Show)

type Access = Access' Type


@@ 188,6 192,7 @@ sizeof tenv = \case
    TPtr _ -> wordsize
    VoidPtr -> wordsize
    TFun _ _ -> wordsize
    TClosure _ _ -> 2 * wordsize
    TConst ix -> case fmap snd (tenv ix) of
        Nothing -> 0
        Just (DEnum vs) -> variantsTagBytes vs

M src/Back/Lower.hs => src/Back/Lower.hs +131 -104
@@ 22,7 22,7 @@ import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as Vec
import Data.Word
import Lens.Micro.Platform (makeLenses, modifying, use, assign, view, assign)
import Lens.Micro.Platform (makeLenses, modifying, use, view, (<<.=), (.=))

import Back.Low (typeof, LowInt(..))
import qualified Back.Low as Low


@@ 45,8 45,9 @@ mapSizedM f = \case

data St = St
    { _strLits :: Map String Low.GlobalId
    , _localNames :: Vector String
    , _globalNames :: Vector String
    , _allocs :: [(Low.LocalId, Low.Type)]
    , _localNames :: Seq String
    , _globalNames :: Seq 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


@@ 77,14 78,13 @@ makeLenses ''Env
data Out = Out
    { _outFunDefs :: [Low.FunDef]
    , _outGlobDefs :: [Low.GlobDef]
    , _outAllocs :: [(Low.LocalId, Low.Type)]
    }
makeLenses ''Out

instance Semigroup Out where
    (<>) (Out a1 b1 c1) (Out a2 b2 c2) = Out (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
    (<>) (Out a1 b1) (Out a2 b2) = Out (a1 ++ a2) (b1 ++ b2)
instance Monoid Out where
    mempty = Out [] [] []
    mempty = Out [] []

type Lower = WriterT Out (StateT St (Reader Env))



@@ 205,14 205,30 @@ lower noGC (Program (Topo defs) datas externs) =
    -- resolveNameConflicts = _

    lowerExterns = forM (Map.toList Ast.builtinExterns ++ externs) $ \case
        (name, TFun pts rt) -> liftM2
            (Low.ExternDecl name)
            (catMaybes <$> mapM (toParam () <=< lowerType) pts)
            (undefined (lowerType rt))
        (name, TFun pts rt) -> do
            (outParam, ret) <- toRet (pure ()) =<< lowerType rt
            ps <- lowerParamTypes pts
            pure $ Low.ExternDecl name (maybe id (:) outParam ps) ret
        (name, t) -> nyi $ "lower: Non-function externs: " ++ name ++ ", " ++ show t

    run :: Lower a -> (a, [Low.FunDef], [Low.GlobDef], Vector Low.TypeDef)
    run = undefined
    run la =
        let ((a, out), st) = runReader (runStateT (runWriterT la) initSt) initEnv
        in  ( a
            , view outFunDefs out
            , view outGlobDefs out
            , Vec.fromList (toList (view tids st))
            )
      where
        initSt = St { _strLits = Map.empty
                    , _allocs = []
                    , _localNames = Seq.empty
                    , _globalNames = Seq.empty
                    , _tconsts = Map.empty
                    , _tids = Seq.empty
                    , _tdefs = Map.empty
                    }
        initEnv = Env { _localEnv = Map.empty, _globalEnv = Map.empty }

    defineInit :: Lower Low.FunDef
    defineInit = pure $ Low.FunDef initNameIx


@@ 243,6 259,7 @@ lower noGC (Program (Topo defs) datas externs) =
                    pure (Just (bind, pid, pt))
        capturesName <- newLName "captures"
        rt' <- lowerType rt
        (outParam, ret) <- toRet (newLName "sret") rt'
        paramTs <- mapM
            (\t -> passByRef t <&> \case
                True -> Low.TPtr t


@@ 253,56 270,45 @@ lower noGC (Program (Topo defs) datas externs) =
        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
        (outerParamIds, body'') <- do
            -- These will be discarded if the function is not tail recursive. In that
            -- case, the inner params and the outer params are the same.
            outerParamIds <- mapM spinoffLocalId innerParamIds
            let outerParams = zipWith Low.Local outerParamIds paramTs
            withVars (capturesBinds ++ binds) $ case rt' of
                ZeroSized -> do
            withVars (capturesBinds ++ binds) $ case (outParam, ret) of
                (Nothing, Low.RetVoid) -> do
                    body' <- lowerExpr Nowhere body
                    pure $ if isTailRec_RetVoid name body'
                        then
                            ( Nothing
                            , outerParamIds
                            ( outerParamIds
                            , tailCallOpt_RetVoid name outerParams innerParams body'
                            )
                        else (Nothing, innerParamIds, mapTerm (\() -> Low.TRetVoid) body')
                Sized t -> passByRef t >>= \case
                    True -> do
                        outParamId <- newLName "sret"
                        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 name body'
                            then
                                ( outParam
                                , outerParamIds
                                , tailCallOpt_RetVoid name outerParams innerParams body'
                                )
                            else
                                ( outParam
                                , innerParamIds
                                , mapTerm (\() -> Low.TRetVoid) body'
                                )
                    False -> do
                        body' <- lowerExpr Here body
                        pure $ if isTailRec_RetVal name body'
                            then
                                ( Nothing
                                , outerParamIds
                                , tailCallOpt_RetVal name outerParams innerParams body'
                                )
                            else (Nothing, innerParamIds, mapTerm Low.TRetVal body')
                        else (innerParamIds, mapTerm (\() -> Low.TRetVoid) body')
                (Nothing, Low.RetVal _) -> do
                    body' <- lowerExpr Here body
                    pure $ if isTailRec_RetVal name body'
                        then
                            ( outerParamIds
                            , tailCallOpt_RetVal name outerParams innerParams body'
                            )
                        else (innerParamIds, mapTerm Low.TRetVal body')
                (Just outParam', Low.RetVoid) -> do
                    let outParamOp = Low.OLocal $ paramLocal outParam'
                    body' <- lowerExpr (There outParamOp) body
                    pure $ if isTailRec_RetVoid name body'
                        then
                            ( outerParamIds
                            , tailCallOpt_RetVoid name outerParams innerParams body'
                            )
                        else (innerParamIds, mapTerm (\() -> Low.TRetVoid) body')
                (Just _, Low.RetVal _) -> unreachable
        let body''' = Low.Block capturesStms () `thenBlock` body''
        localNames' <- popLocalNames
        assign localNames oldLocalNames
        allocs <- popAllocs
        localNames' <- fmap (Vec.fromList . toList) $ localNames <<.= oldLocalNames
        allocs' <- allocs <<.= []
        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)])


@@ 388,18 394,9 @@ lower noGC (Program (Topo defs) datas externs) =
    spinoffLocalId :: Low.LocalId -> Lower Low.LocalId
    spinoffLocalId x = do
        names <- use localNames
        let name = names Vec.! fromIntegral x
        let name = Seq.index names (fromIntegral x)
        newLName name

    popLocalNames :: Lower Low.VarNames
    popLocalNames = do
        xs <- use localNames
        assign localNames Vec.empty
        pure xs

    popAllocs :: Lower Low.Allocs
    popAllocs = undefined

    lowerExpr :: Destination d => d -> Expr -> Lower (Low.Block (DestTerm d))
    lowerExpr dest = \case
        Lit c -> toDest dest . Sized . operandToExpr =<< lowerConst c


@@ 413,11 410,27 @@ lower noGC (Program (Topo defs) datas externs) =
                . map (mapTerm (sized (: []) []))
                =<< mapM (lowerExpr HereSized) as
            Low.Block stms3 captures <- bindBlockM load =<< indexStruct 0 closure
            Low.Block stms4 f' <- bindBlockM load =<< indexStruct 1 closure
            fmap (thenBlock (Low.Block (stms1 ++ stms2 ++ stms3 ++ stms4) ()))
                . toDest dest
                . mapSized (Low.Expr (Low.Call f' (captures : as')))
                $ returneeType (typeof f')
            Low.Block stms4 fGeneric <- bindBlockM load =<< indexStruct 1 closure
            let (params, ret) = asTClosure (pointee (typeof closure))
            let tfConcrete = Low.TFun params ret
            Low.Block stms5 fConcrete <- emit
                $ Low.Expr (Low.Bitcast fGeneric tfConcrete) tfConcrete
            let args = captures : as'
            -- Some types are kept on the stack for convenience when lowering, and may
            -- need to be loaded to registers before being passed
            let removeExtraIndirection p a = do
                    let tp = paramType p
                    let ta = typeof a
                    if Low.TPtr tp == ta then load a else pure (Low.Block [] a)
            Low.Block stms6 args' <-
                catBlocks <$> zipWithM removeExtraIndirection params args
            thenBlockM (Low.Block (concat [stms1, stms2, stms3, stms4, stms5, stms6]) ())
                $ case ret of
                      Low.RetVoid ->
                          Low.Block [Low.VoidCall fConcrete args'] ()
                              `thenBlockM` toDest dest ZeroSized
                      Low.RetVal tret ->
                          toDest dest (Sized (Low.Expr (Low.Call fConcrete args') tret))
        If pred conseq alt ->
            lowerExpr Here pred
                `bindrBlockM'` emitNamed "predicate"


@@ 483,9 496,14 @@ lower noGC (Program (Topo defs) datas externs) =
        bindrBlockM captures $ \captures' -> do
            fdef <- lowerFunDef freeLocalVars "fun" f
            scribe outFunDefs [fdef]
            let f' = Low.OGlobal $ funDefGlobal fdef
            (ptr, x) <- allocationAtDest dest (Just "closure") closureType
            populateStruct [captures', f'] ptr <&> mapTerm (const x)
            let fConcrete = Low.OGlobal $ funDefGlobal fdef
            fGeneric <- emit (Low.Expr (Low.Bitcast fConcrete Low.VoidPtr) Low.VoidPtr)
            (ptr, x) <- allocationAtDest dest (Just "closure")
                $ Low.TClosure
                      (map Low.dropParamName (Low.funDefParams fdef))
                      (Low.funDefRet fdef)
            bindrBlockM fGeneric $ \fGeneric' ->
                populateStruct [captures', fGeneric'] ptr <&> mapTerm (const x)

    lowerTag :: Span -> VariantIx -> Low.Operand
    lowerTag span variantIx = Low.OConst . Low.CInt $ case tagBits span :: Int of


@@ 514,8 532,8 @@ lower noGC (Program (Topo defs) datas externs) =
            Low.Block stmsExpr result <- lowerExpr (ThereSized subPtr) e
            case result of
                Sized () ->
                    thenBlock (Low.Block (stmsIndex ++ stmsExpr) ()) <$> go (i + 1) es
                ZeroSized -> thenBlock (Low.Block stmsExpr ()) <$> go i es
                    Low.Block (stmsIndex ++ stmsExpr) () `thenBlockM` go (i + 1) es
                ZeroSized -> Low.Block stmsExpr () `thenBlockM` go i es

    captureFreeLocalVars (params, (body, _)) = do
        let params' = Set.fromList params


@@ 659,7 677,7 @@ lower noGC (Program (Topo defs) datas externs) =
                            pure $ block `thenBlock` branchToDest
                                dest
                                (Low.BIf isMatch conseq alt)
                thenBlock block <$> lowerCases (Map.toAscList cases)
                block `thenBlockM` lowerCases (Map.toAscList cases)

        -- Type checker wouldn't let us switch on something zero-sized, so we can
        -- safely unwrap the Sized


@@ 733,6 751,9 @@ lower noGC (Program (Topo defs) datas externs) =
    thenBlock :: Low.Block () -> Low.Block a -> Low.Block a
    thenBlock (Low.Block stms1 ()) (Low.Block stms2 a) = Low.Block (stms1 ++ stms2) a

    thenBlockM :: Low.Block () -> Lower (Low.Block a) -> Lower (Low.Block a)
    thenBlockM b1 mb2 = bindrBlockM b1 (\() -> mb2)

    bindBlock :: (a -> Low.Block b) -> Low.Block a -> Low.Block b
    bindBlock f (Low.Block stms1 a) =
        let Low.Block stms2 b = f a in Low.Block (stms1 ++ stms2) b


@@ 795,7 816,7 @@ lower noGC (Program (Topo defs) datas externs) =
          )
        ]

    closureType = builtinType "closure"
    closureStruct = builtinType "closure"

    builtinType name = Low.TConst $ fromIntegral $ fromJust $ findIndex
        ((== name) . fst)


@@ 804,8 825,8 @@ lower noGC (Program (Topo defs) datas externs) =
    defineDatas :: Lower ()
    defineDatas = do
        (tids', _) <- mfix $ \(tids', tconsts') -> do
            assign tids tids'
            assign tconsts tconsts'
            tids .= tids'
            tconsts .= tconsts'
            bimap (Seq.fromList . (builtinTypeDefs ++)) Map.fromList . snd <$> foldlM
                (\(i, (env, ids)) (inst@(name, _), variants) ->
                    fmap (bimap (i +) ((env, ids) <>))


@@ 820,7 841,7 @@ lower noGC (Program (Topo defs) datas externs) =
                (fromIntegral (length builtinTypeDefs), ([], []))
                (Map.toList datas)
        let tdefs' = Map.fromList $ zip (toList tids') [0 ..]
        assign tdefs tdefs'
        tdefs .= tdefs'
      where
        defineData
            :: Low.TypeId


@@ 881,6 902,9 @@ lower noGC (Program (Topo defs) datas externs) =
    --             (name', seen') = uq (Map.findWithDefault 0 name seen)
    --         in  (set name' d : ds, seen')

    lowerParamTypes :: [Type] -> Lower [Low.Param ()]
    lowerParamTypes pts = catMaybes <$> mapM (toParam () <=< lowerType) pts

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


@@ 890,11 914,21 @@ lower noGC (Program (Topo defs) datas externs) =
        True -> Low.ByRef name t
        False -> Low.ByVal name t

    toRet = \case
        ZeroSized -> pure Low.RetVoid
        Sized t -> passByRef t <&> \case
            True -> Low.RetVoid
            False -> Low.RetVal t
    paramType = \case
        Low.ByVal _ t -> t
        Low.ByRef _ t -> Low.TPtr t

    paramLocal :: Low.Param Low.LocalId -> Low.Local
    paramLocal = \case
        Low.ByVal name t -> Low.Local name t
        Low.ByRef name t -> Low.Local name (Low.TPtr t)

    toRet :: Lower name -> Sized Low.Type -> Lower (Maybe (Low.Param name), Low.Ret)
    toRet genName = \case
        ZeroSized -> pure (Nothing, Low.RetVoid)
        Sized t -> passByRef t >>= \case
            True -> genName <&> \name -> (Just (Low.ByRef name t), Low.RetVoid)
            False -> pure (Nothing, Low.RetVal t)

    lowerSizedTypes :: [Type] -> Lower [Low.Type]
    lowerSizedTypes = fmap catMaybes . mapM (fmap sizedMaybe . lowerType)


@@ 911,7 945,11 @@ lower noGC (Program (Topo defs) datas externs) =
        TPrim TIntSize -> pure $ genIntT wordsizeBits
        TPrim TF32 -> pure $ Sized Low.TF32
        TPrim TF64 -> pure $ Sized Low.TF64
        TFun _ _ -> pure $ Sized closureType
        TFun tparams tret -> do
            (outParam, ret) <- toRet (pure ()) =<< lowerType tret
            params <- lowerParamTypes tparams
            let captures = Low.ByVal () Low.VoidPtr
            pure (Sized (Low.TClosure (maybe id (:) outParam $ captures : params) ret))
        TBox t -> lowerType t <&> \case
            ZeroSized -> Sized Low.VoidPtr
            Sized t' -> Sized $ Low.TPtr t'


@@ 932,18 970,21 @@ lower noGC (Program (Topo defs) datas externs) =
        Low.TPtr t -> t
        _ -> ice "Lower.pointee of non pointer type"

    returnee = \case
        Low.TFun _ ret -> ret
        _ -> ice "Lower.returnee of non function type"
    asTFun = \case
        Low.TFun params ret -> (params, ret)
        _ -> ice "Lower.asTFun of non function type"

    asTClosure = \case
        Low.TClosure params ret -> (params, ret)
        _ -> ice "Lower.asTClosure of non function type"

    returneeType = returnee >>> \case
        Low.RetVal t -> Sized t
        Low.RetVoid -> ZeroSized
    returnee = snd . asTFun

    getTypeStruct = \case
        Low.TConst i -> use tids <&> (Seq.!? fromIntegral i) <&> \case
            Just (_, Low.DStruct struct) -> struct
            _ -> ice "Low.getTypeStruct: TypeDef in tenv is not DStruct"
        Low.TClosure _ _ -> getTypeStruct closureStruct
        _ -> ice "Low.getTypeStruct: type is not a TConst"

    -- TODO: Maybe we could get rid of all ad-hoc logic using this function, by wrapping


@@ 987,33 1028,19 @@ funDefGlobal Low.FunDef { Low.funDefName = x, Low.funDefParams = ps, Low.funDefR
stackAlloc :: Maybe String -> Low.Type -> Lower Low.Operand
stackAlloc name t = do
    x <- newLName (fromMaybe "tmp" name)
    scribe outAllocs [(x, t)]
    modifying allocs ((x, t) :)
    pure (Low.OLocal (Low.Local x (Low.TPtr t)))

-- | To generate cleaner code, a data-type is only represented as a tagged union (Data) if
--   it has to be. If there is only a single variant, we skip the tag and represent it as
--   a Struct. If the struct also has no members, we simplify it further and represent it
--   as a Unit. If instead the data-type has multiple variants, but no variant has any
--   members, it is represented as an Enum.
-- lowerDatas :: ()
-- lowerDatas = ()

-- instance TypeAst Type where
--     tprim = TPrim
--     tconst = TConst
--     tfun = TFun
--     tbox = TBox

newLName :: String -> Lower Low.LocalId
newLName x = do
    localId <- Vec.length <$> use localNames
    modifying localNames (`Vec.snoc` x)
    localId <- Seq.length <$> use localNames
    modifying localNames (Seq.|> x)
    pure (fromIntegral localId)

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

mapTerm :: (a -> b) -> Low.Block a -> Low.Block b

M src/Misc.hs => src/Misc.hs +3 -0
@@ 31,6 31,9 @@ ice = error . ("Internal Compiler Error: " ++)
nyi :: String -> a
nyi = error . ("Not yet implemented: " ++)

unreachable :: a
unreachable = ice "unreachable"

-- | Like `intercalate`, but concatenate a list with a prefix before each
--   element, instead of an separator between each pair of elements.
precalate :: [a] -> [[a]] -> [a]