Commit 4e3377a2 authored by nathyong's avatar nathyong

Implement variable capturing

parent 70a4766e
Pipeline #5 failed with stage
in 4 minutes and 45 seconds
......@@ -16,8 +16,9 @@ cabal-version: >=1.10
library
hs-source-dirs: src
other-extensions:
TemplateHaskell,
GeneralizedNewtypeDeriving
GeneralizedNewtypeDeriving,
OverloadedStrings,
DeriveGeneric
ghc-options: -Wall
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
......@@ -48,7 +49,6 @@ executable anuhc-exe
, mu
, mu-pure
, containers
, directory
, ghc-simple
, text
default-language: Haskell2010
......
......@@ -43,14 +43,14 @@ compilerConfig =
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = ["-ddump-stg", "-ddump-cmm-raw", "-ddump-to-file"] {-"-v5",-}
, cfgCacheDirectory = Just "/tmp/"
, cfgCacheDirectory = Just "/tmp/anuhc/"
}
main :: IO ()
main = do
inputFiles <- getArgs
b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles
libresults <- mapM compileLibraryFiles libraryFiles
libresults <- return [] -- mapM compileLibraryFiles libraryFiles
case b of
Success results _ _ -> do
doResults lives $ mergeResults $ (loadPrim : concat libresults ++ results')
......@@ -60,8 +60,8 @@ main = do
getDefns (defns, _, _) = fmap toName defns
Failure _ _ -> exitFailure
compileLibraryFiles :: (String, [FilePath]) -> IO [MuResult]
compileLibraryFiles (packageKey, files) = do
compileLibraryFiles :: (String, [FilePath], [String]) -> IO [MuResult]
compileLibraryFiles (packageKey, files, extraFlags) = do
traceM ("Compiling the library file " ++ packageKey)
b <- GHC.Simple.compileWith libconfig compileMu files
case b of
......@@ -70,7 +70,9 @@ compileLibraryFiles (packageKey, files) = do
where
libconfig = compilerConfig
{ cfgGhcFlags =
["-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"]
[ "-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"
, "-I/Users/nathan/projects/microvm/anuhc/libraries/include/"]
++ extraFlags
}
doResults :: [Name] -> MuMergedResult -> IO ()
......@@ -97,9 +99,9 @@ doResults liveObjectNames (defns, topClosures, mainFunction) = do
-- | A list of all library files, indexed by their package-key.
-- TODO: fix this.
libraryFiles :: [(String, [FilePath])]
libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles)
, ("base", prefix baseFiles)
libraryFiles :: [(String, [FilePath], [String])]
libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles, [])
, ("base", prefix baseFiles, ["-I/Users/nathan/projects/microvm/anuhc/libraries/base/include/", "-i/Users/nathan/projects/microvm/anuhc/libraries/base"])
]
where
prefix = fmap ("/Users/nathan/projects/microvm/anuhc/libraries/" ++)
......
This diff is collapsed.
......@@ -18,14 +18,20 @@ module Compiler.Mu.FromSTG
) where
import Control.Monad (void, when)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Data.Map.Strict (Map)
import Control.Monad (void, when, foldM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (Reader, ReaderT, MonadReader, runReaderT, ask, local)
import Control.Monad.State.Strict (State, StateT, MonadState, evalState, runStateT, gets)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
import Data.Char (ord)
import Data.String (fromString)
import Data.Monoid ((<>))
import qualified Data.Map.Strict as M
import Literal (Literal(..))
import DataCon (DataCon, dataConWrapId, dataConRepRepArity, dataConTag)
import DataCon (DataCon, dataConWrapId, dataConRepRepArity, dataConTag, isUnboxedTupleCon)
import BasicTypes (RecFlag(..))
import Outputable (Outputable, pprTraceIt)
import Language.Haskell.GHC.Simple (ModMetadata(..))
......@@ -38,6 +44,8 @@ import StgSyn
import qualified GHC as GHC
import qualified Literal as Lit
import qualified Var as Var
import Compiler.Mu.CodeGen
import Mu.AST
......@@ -46,10 +54,12 @@ import Debug.Trace
-- | Compile the information inside an STG module into a 'Bundle'.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do
stgToMu modData (tyCons, bindings) = bundleMu modName $ do
loadTypes
mapM_ codegenTop bindings
mapM_ codegenType tyCons
where
modName = traceShowId $ mmName modData
-- | Generate code for a top-level STG binding in Mu.
......@@ -78,7 +88,6 @@ codegenEnumerations _tycon = return ()
-- | Generate the static closures for data constructor fields.
codegenDataCon :: DataCon -> Mu ()
codegenDataCon dcon = do
traceShowM ("data con static entry", (dataConEntry dcon))
closure dcon [] $ do
-- The undersaturated and exact application cases are exactly the same,
-- just return the same closure with a tag
......@@ -91,7 +100,6 @@ codegenDataCon dcon = do
where
funcName = dataConEntry dcon
entry = funcName `dot` "entry"
exact = funcName `dot` "exact"
this = entry `dot` "this"
......@@ -116,29 +124,183 @@ codegenTop' name rhs = case rhs of
Lit.MachStr str -> do
strName <- string name str
return $ TaggedPointer strName 0
Lit.MachNullAddr -> error "machNullAddr" -- NullCtor
Lit.MachLabel {} -> error "machLabel" -- ExternCtor "label"
Lit.MachNullAddr -> do
traceShowM ("MachNullAddr inside", closureNameOf name)
return NullPointer
Lit.MachLabel {} -> do
-- TODO: replace with something else
traceShowM ("MachLabel inside", closureNameOf name)
return NullPointer
StgVarArg argId -> return $ TaggedPointer (closureNameOf argId) 0
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body -> do
-- traceShowM ("stg closure", closureNameOf name)
closure name [] $ closureBody name vars body
-- | Generate the closure code corresponding to an 'StgExpr'.
closureBody :: GHC.Id -> [GHC.Id] -> StgExpr -> Mu FunctionName
closureBody name _ _ | traceShow ("closurebody", (entryNameOf name)) False = undefined
closureBody name vars body = do
funcdef funcName (Version "1") muClosureFunctionSig $ do
return $ BasicBlock bbName [(paramName, muClosureRef)] Nothing
[]
(Return [paramName])
funcdef funcName (Version "1") muClosureFunctionSig $
basicBlock entry [(this, muClosureRef)] $ do
withBindings entry this vars $ do
sequel <- lift $ placeholderBlocks (fromString "@zzz")-- expression name body
traceShowM ("gonna branch to ", sequel)
boundNames <- sortedIDNames
return $ Branch1 $ DestinationClause sequel boundNames
return funcName
where
entry = funcName `dot` "entry"
this = funcName `dot` "entry.this"
funcName = entryNameOf name
bbName = funcName `dot` "entry"
paramName = bbName `dot` "param"
retVal = bbName `dot` "ret"
-- | Bind some arguments from a closure to actual Mu values.
--
-- For this to work, there need to be at least as many values in the closure as
-- there are arguments that need to be bound.
withBindings :: BasicBlockName -- ^ Name of the current 'BasicBlock'
-> VarName -- ^ Variable pointing to the closure with the
-- arguments to bind
-> [GHC.Id] -- ^ Arguments to bind
-> ExpWriter a
-> ExpWriter a
withBindings name this vars code = do
thisRef <- assign $ GetVarPartIRef False muClosure this
one <- upConstant 1
let bindArg :: (VarName, CapturedIDs) -> GHC.Id -> ExpWriter (VarName, CapturedIDs)
bindArg (ref, cIDs) var = do
val <- assign $ Load False Nothing haskellData thisRef Nothing
ref' <- assign $ ShiftIRef False muClosure i64 ref one
return (ref', M.insert var val cIDs)
bindings <- ask
(_, cIDs') <- foldM bindArg (thisRef, bindings) vars
code `capturing` cIDs'
-- | Emit a basic block that returns a new closure.
mkClosure :: FunctionName -- ^ The enclosing function for this block (for
-- naming purposes)
-> FunctionName -- ^ The function to be called
-> [StgArg] -- ^ List of arguments
-> Blocks BasicBlockName
mkClosure outerFun target args = do
bb <- basicBlock entry [] $ mkClosure' targetName args
emitBB bb
return entry
where
entry = outerFun `dot` "mkClosure"
this = entry `dot` "this"
targetName = VarName $ toName target
-- | Emit a basic block that returns a new closure. Also generate code to
-- extract the entry function from any 'GHC.Id' first.
mkClosureIndirect :: FunctionName
-> GHC.Id
-> [StgArg]
-> Blocks BasicBlockName
mkClosureIndirect outerFun targetID args = do
bb <- basicBlock entry [] $ do
targetName <- lookupID targetID
mkClosure' targetName args
emitBB bb
return entry
where
entry = outerFun `dot` "mkClosure"
this = entry `dot` "this"
-- | Create and populate a Mu Closure
mkClosure' :: VarName -- ^ Variable holding the name of the closure
-> [StgArg] -- ^ List of arguments
-> ExpWriter Expression
mkClosure' target args = do
-- create the closure
closLen <- upConstant (length args)
clos <- assign $ NewHybrid muClosure i64 closLen Nothing
-- populate the fields
closFunctionField <- assign $ GetFieldIRef False muClosure (fromEnum EntryField) clos
emit $ Store False Nothing muClosureFunction closFunctionField target Nothing
-- TODO: figure out the arity of this closure
-- TODO: populate the arguments
return $ Return [clos]
instance Show Var.Var where
show = show . entryNameOf
expression :: GHC.Id -- ^ The ID of the enclosing closure this belongs to
-> StgExpr -- ^ STG Expression to translate
-> Blocks BasicBlockName -- ^ The name of the block that starts
-- this expression
expression name topExpr = do
bindings <- ask
traceShowM ("inside expression for: ", entryNameOf name)
traceShowM ("bindings are: ", bindings)
case topExpr of
StgApp fun args
| isInternal fun -> traceShow ("internal StgApp", entryNameOf fun) $ do
mkClosureIndirect (entryNameOf name) fun args
| otherwise -> mkClosure (entryNameOf name) (entryNameOf fun) args
StgConApp con args
| isUnboxedTupleCon con -> traceShow ("unboxed StgConApp", dataConEntry con)
$ mkClosure (entryNameOf name) (dataConEntry con) args
-- error . show $ ("StgConApp unboxedtuple not implemented", closureNameOf name)
| otherwise -> traceShow ("StgConApp", dataConEntry con) $ mkClosure (entryNameOf name) (dataConEntry con) args
StgOpApp {} -> placeholderBlocks (entryNameOf name)
StgCase {} ->
placeholderBlocks (entryNameOf name)
StgLet binds expr -> do
-- traceShowM (showBind binds)
placeholderBlocks (entryNameOf name)
-- expression expr
where
showBind (StgNonRec bindId _) = show $ closureNameOf bindId
showBind (StgRec binds) = show $ fmap (closureNameOf . fst) binds
StgLetNoEscape _live_lhs _live_rhs binds expr -> expression name (StgLet binds expr)
StgLam {} -> error "panic: found a StgLam expression"
StgLit {} -> error "StgLit not implemented"
StgTick {} -> error "StgTick not implemented"
where
entry = entryNameOf name
-- Note [Applications]
-- ~~~~~~~~~~~~~~~~~~~
--
-- StgApp bindings can be used for many different things; for example the `id`
-- function translates to an StgApp of the first argument (whatever it is).
-- This might be a function, it might be a data value, it could be anything.
placeholderBlocks :: FunctionName -> Blocks BasicBlockName
placeholderBlocks n = do
emitBB $ BasicBlock bbName [(param, muClosureRef)] Nothing
[]
(Return [param])
return bbName
where
bbName = n `dot` "placeholder"
param = bbName `dot` "param"
retVal = bbName `dot` "ret"
-- -- | Generate code for constructor applications at the top level.
-- cgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
......@@ -200,6 +362,7 @@ _pprError
:: Outputable a
=> String -> a -> b
_pprError msg val = seq (pprTraceIt msg val) undefined
-- import StgSyn
--
-- import Util (unzipWith)
......
......@@ -22,12 +22,12 @@ import Mu.AST
loadPrim :: MuResult
loadPrim = bundleMu $ do
loadPrim = bundleMu "__prim__ops__" $ do
return ()
-- stub "@zdghczmprimzdGHCziTypeszdModule_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTyCon_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTrNameS_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTrNameD_static_entry"
stub "@zdghczmprimzdGHCziTypeszdModule_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTyCon_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameS_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameD_static_entry"
stub :: FunctionName -> Mu ()
......
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