Commit 8aecd888 authored by nathyong's avatar nathyong

Populate top-level closures and byte arrays

parent 6241e687
......@@ -60,7 +60,7 @@ doResults (bundle, topClosures, mainFunction) = do
ctx <- newContext mu
buildBundle ctx bundle
mapM_ buildClosures topClosures
mapM_ (populate ctx) topClosures
liveObjects <- mapM (getID ctx) $ fmap toName (unBundle bundle)
whitelist <- newArray $ toList liveObjects
......
......@@ -9,7 +9,7 @@
module Compiler.Mu
( compileMu
, buildClosures
, populate
, MuResult
) where
......@@ -18,7 +18,7 @@ import StgSyn (StgBinding)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.CodeGen (MuResult, buildClosures)
import Compiler.Mu.CodeGen (MuResult, populate)
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult
compileMu metadata stg = return $ stgToMu metadata stg
This diff is collapsed.
......@@ -22,6 +22,7 @@ import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Data.Char (ord)
import Data.String (fromString)
import Data.Monoid ((<>))
import Literal (Literal(..))
import DataCon (DataCon, dataConWrapId)
......@@ -35,27 +36,29 @@ import StgSyn
(StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg,
GenStgArg(..), StgExpr, GenStgExpr(..), UpdateFlag(..))
import qualified GHC as GHC
import qualified Literal as Lit
import Compiler.Mu.CodeGen
import Mu.AST
import Debug.Trace
-- | Compile the information inside an STG module into a 'Bundle'.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do
loadTypes
let funcName = "@__placeholder"
bbName = funcName `subName` "entry"
param = bbName `subName` "param"
retVal = bbName `subName` "ret"
in funcdef funcName (Version "1") muClosureFunctionSig $ do
return $ BasicBlock bbName [(param, muClosureRef)] Nothing
[[retVal] := getClosureTag param]
(Return [retVal])
mapM_ codegenTop bindings
-- | Load a bunch of useful types into the current bundle.
loadTypes :: Mu ()
loadTypes = do
typedef "@_mu_tagref" TagRef64
typedef "@i64" $ MuInt 64
typedef "@_mu_hybrid" $ Hybrid ["@i64", "@_mu_tagref"] "@i64"
return ()
-- mapM_ codegenTopTypes tyCons
codegenTop :: StgBinding -> Mu ()
codegenTop binding =
......@@ -69,44 +72,50 @@ codegenTop binding =
codegenTop' :: GHC.Id -> StgRhs -> Mu ()
codegenTop' name rhs = case rhs of
-- make the top-level constructor, need to output code for it?
-- emitTop name (TypeTop name (length args) con)
StgRhsCon _cc con args -> do
constant (fromString (stringify name)) "@i64" (IntCtor 1337)
return ()
argLits <- mapM literal args
closure name argLits $ return "@__placeholder"
where
-- funcName = fromString $ stringify name <> "_static_entry"
-- bbName = funcName `subName` "entry"
-- param = bbName `subName` "param"
-- retVal = bbName `subName` "ret"
literal arg = case arg of
StgLitArg lit -> case lit of
Lit.MachInt i -> return $ UnboxedInt i
Lit.MachInt64 i -> return $ UnboxedInt i
Lit.MachWord i -> return $ UnboxedInt i
Lit.MachWord64 i -> return $ UnboxedInt i
Lit.MachFloat r -> return $ UnboxedDouble r
Lit.MachDouble r -> return $ UnboxedDouble r
Lit.LitInteger i _ -> return $ UnboxedInt i
Lit.MachChar c -> return $ UnboxedInt $ fromIntegral (ord c)
Lit.MachStr str -> do
strName <- string name str
return $ TaggedPointer strName 0
Lit.MachNullAddr -> error "machNullAddr" -- NullCtor
Lit.MachLabel {} -> error "machLabel" -- ExternCtor "label"
StgVarArg argId -> return $ TaggedPointer (closureNameOf argId) 0
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
closure name (length vars) $ cgClosureBody vars body
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body -> do
closure name [] $ closureBody name vars body
cgClosureBody :: [GHC.Id] -> StgExpr -> Mu FunctionName
cgClosureBody vars body = do
return $ "FunctionName"
closureBody :: GHC.Id -> [GHC.Id] -> StgExpr -> Mu FunctionName
closureBody name vars body = do
funcdef funcName (Version "1") muClosureFunctionSig $ do
return $ BasicBlock bbName [(paramName, muClosureRef)] Nothing
[[retVal] := GetFieldIRef False muClosure 2 paramName]
(Return [retVal])
return funcName
where
funcName = entryNameOf name
bbName = funcName `subName` "entry"
paramName = bbName `subName` "param"
retVal = bbName `subName` "ret"
-- -- | Convert an StgBinding to Mu Code.
-- cgBindings :: StgBinding -> MuCode ()
-- cgBindings stgBinding =
-- case stgBinding of
-- StgNonRec bindId rhs -> do
-- let (bindInfo, code) = muTopBinding NonRecursive bindId rhs
-- muBind bindInfo
-- code
-- StgRec pairs -> do
-- let (bindInfos, codes) =
-- unzip $ unzipWith (muTopBinding Recursive) pairs
-- mapM_ muBind bindInfos
-- sequence_ codes
-- where unzipWith f = map (uncurry f)
--
-- muTopBinding :: RecFlag -> Id -> StgRhs -> (MuBindInfo, MuCode ())
-- muTopBinding flag bndr rhs =
-- case rhs of
-- StgRhsCon _cc con arg -> cgTopRhsCon con bndr arg
-- StgRhsClosure _cc _bindinfo _nonfrees updateflag _srt vars body ->
-- cgTopRhsClosure flag bndr updateflag vars body
--
-- -- | Generate code for constructor applications at the top level.
-- cgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
-- cgTopRhsCon con bndr args = (info, code)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment