GitLab will be upgraded on June 2nd 2020 at 2.00 pm (AEDT) to 3.00 pm (AEDT) due to Critical Security Patch Availability. During the update, GitLab and Mattermost services will not be available. If you have any concerns with this, please talk to local Gitlab admin team.

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