GitLab will continue to be upgraded from 11.4.5-ce.0 on November 25th 2019 at 4.00pm (AEDT) to 5.00pm (AEDT) due to Critical Security Patch Availability. During the update, GitLab and Mattermost services will not be available.

Commit 7370e42a authored by nathyong's avatar nathyong

Begin adding support for ghc-prim types

It's really good that by setting the module name to ghc-prim, GHC itself
will assume that there are no types that currently exist.  Hence, I can
get it to type check the entire thing and generate the bindings without
actually generating the code.
parent 37d3cf66
......@@ -17,3 +17,5 @@ cabal.sandbox.config
*.eventlog
.stack-work/
cabal.project.local
*.dump-*
This diff is collapsed.
......@@ -48,6 +48,7 @@ executable anuhc-exe
, mu
, mu-pure
, containers
, directory
, ghc-simple
, text
default-language: Haskell2010
......
......@@ -13,7 +13,8 @@
module Main where
import Data.Monoid ((<>))
import Data.List (genericLength)
import Data.Foldable (foldMap, toList)
import Data.List (isSuffixOf)
import Foreign.C.String (newCString)
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Array (newArray)
......@@ -21,6 +22,7 @@ import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
import System.Directory (listDirectory)
import qualified Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple.Extra ()
......@@ -33,34 +35,51 @@ import Mu.AST
import Mu.Impl.RefImpl2
import Mu.Interface
compilerConfig :: CompConfig
compilerConfig =
GHC.Simple.disableCodeGen $
GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = ["-ddump-stg", "-ddump-cmm-raw", "-ddump-to-file"] {-"-v5",-}
, cfgCacheDirectory = Just "/tmp/"
}
main :: IO ()
main = do
_ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs
b <- GHC.Simple.compileWith config compileMu inputFiles
b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles
libresults <- compileLibraryFiles
case b of
Success results _ _ -> do
putStrLn "Success!"
doResults $ mergeResults $ (loadPrim:) $ fmap modCompiledModule (results)
doResults lives $ mergeResults $ (loadPrim : libresults ++ results')
where
results' = fmap modCompiledModule (results)
lives = toList $ foldMap getDefns results'
getDefns (defns, _, _) = fmap toName defns
Failure _ _ -> exitFailure
compileLibraryFiles :: IO [MuResult]
compileLibraryFiles = do
b <- getLibraryFiles >>= GHC.Simple.compileWith libconfig compileMu
case b of
Success results _ _ -> return $ fmap modCompiledModule results
Failure _ _ -> error "Could not compile internal bundle"
where
config =
GHC.Simple.disableCodeGen $
GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = [{-"-v5",-} "-ddump-stg", "-ddump-to-file"]
libconfig = compilerConfig
{ cfgGhcFlags =
["-this-unit-id", "ghc-prim", "-ddump-stg", "-ddump-to-file"]
}
doResults :: MuMergedResult -> IO ()
doResults (defns, topClosures, mainFunction) = do
doResults :: [Name] -> MuMergedResult -> IO ()
doResults liveObjectNames (defns, topClosures, mainFunction) = do
mu <- newMu
ctx <- newContext mu
buildBundle ctx (Bundle defns')
mapM_ (populate ctx) topClosures
liveObjects <- mapM (getID ctx) $ fmap toName defns'
liveObjects <- mapM (getID ctx) liveObjectNames
whitelist <- newArray liveObjects
let whitelistSz = fromIntegral . length $ liveObjects
......@@ -74,6 +93,13 @@ doResults (defns, topClosures, mainFunction) = do
where
defns' = M.elems defns
getLibraryFiles :: IO [FilePath]
getLibraryFiles = process =<< mapM listDirectory'
["/Users/nathan/projects/microvm/anuhc/anuhc-prim/GHC/"]
where
process = return . (filter (".hs" `isSuffixOf`) . concat)
listDirectory' dir = listDirectory dir >>= return . (fmap (dir ++))
-- printResult :: CompResult String -> IO ()
-- printResult result = do putStrLn errors
-- putStrLn warnings
......@@ -90,7 +116,7 @@ doResults (defns, topClosures, mainFunction) = do
-- showWarns = concatMap showIt
-- where
-- showIt (Warning span msg) = show span ++ " " ++ msg
--
--
-- showErrors :: [Error] -> String
-- showErrors = concatMap showIt
-- where
......@@ -41,6 +41,7 @@ module Compiler.Mu.CodeGen
, closure
, string
-- * Naming interface
, tyconClosureName
, dataConEntry
, closureNameOf
, entryNameOf
......@@ -50,15 +51,15 @@ module Compiler.Mu.CodeGen
, i8
, muString
-- * STG Closures in Mu
, closureTag
, closureTR
, muClosure
, muClosureRef
, muClosureFunction
, muClosureFunctionSig
, haskellData
, getClosureEntry
, getClosureTag
, getClosureField
, getClosureData
, ClosureField (..)
) where
import Control.Applicative ((<|>))
......@@ -81,7 +82,7 @@ import Lens.Micro.Platform ((%=), makeLenses)
import FastString (fsLit, zEncodeFS, zString)
import qualified GHC
import Name (NamedThing (..), nameStableString, isSystemName)
import Name (NamedThing (..), nameStableString, isSystemName, isInternalName)
import Unique (Uniquable (..))
import Mu.API
......@@ -186,13 +187,16 @@ populate ctx top = case top of
closureIref <- getIref ctx closureRef
one <- handleFromSint64 ctx 1 52
closureTagRef <- getFieldIref ctx closureIref 1
store ctx muOrdNotAtomic closureTagRef =<< tr64FromInt ctx one
closureEntryRef <- getFieldIref ctx closureIref 0
closureEntryRef <- getFieldIref ctx closureIref (fieldIx EntryField)
entryRef <- getID ctx entry >>= handleFromFunc ctx
store ctx muOrdNotAtomic closureEntryRef entryRef
closureLengthRef <- getFieldIref ctx closureIref (fieldIx NArgsField)
store ctx muOrdNotAtomic closureLengthRef closureLength
closureTagRef <- getFieldIref ctx closureIref (fieldIx TagField)
store ctx muOrdNotAtomic closureTagRef one
closureDataRef <- getVarPartIref ctx closureIref
let storePayloads datums ref = case datums of
[] -> return ()
......@@ -242,7 +246,8 @@ populate ctx top = case top of
-- | Emit a closure with a payload and an entry function. The closure itself
-- will be allocated during build time.
closure :: GHC.Id -> [UnboxedData] -> Mu FunctionName -> Mu ()
closure :: (Uniquable a, NamedThing a)
=> a -> [UnboxedData] -> Mu FunctionName -> Mu ()
closure name payload code = do
func_name <- code
topLevels %= (|> Closure name' payload func_name)
......@@ -300,11 +305,13 @@ stringify a
stableName = zString . zEncodeFS . fsLit . nameStableString
uniquePart = show . getUnique
tyconClosureName :: GHC.TyCon -> GlobalCellName
tyconClosureName n = GlobalCellName $ Name $ stringify n <> "_closure"
dataConEntry :: GHC.DataCon -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"
closureNameOf :: GHC.Id -> GlobalCellName
closureNameOf :: (Uniquable a, NamedThing a) => a -> GlobalCellName
closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
entryNameOf :: GHC.Id -> FunctionName
......@@ -317,16 +324,19 @@ entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
-- definitions is arbitrary.
loadTypes :: Mu ()
loadTypes = do
funcsig muClosureFunctionSig [muClosureRef] [haskellData]
funcsig muClosureFunctionSig [closureTR] [closureTR]
typedef haskellData TagRef64
typedef closureTag TagRef64
typedef closureTR TagRef64
typedef i64 $ MuInt 64
constant i64_1 i64 (IntCtor 1)
typedef i8 $ MuInt 8
typedef muString $ Hybrid [] i8
typedef muStringRef $ Ref muString
typedef muClosureMetadata $ MuInt 8
typedef muClosureFunction $ FuncRef muClosureFunctionSig
typedef muClosure $ Hybrid [muClosureFunction, closureTag] haskellData
typedef muClosure $
Hybrid [muClosureFunction, muClosureMetadata, muClosureMetadata]
haskellData
typedef muClosureRef $ Ref muClosure
i64 :: TypedefName
......@@ -342,10 +352,19 @@ muStringRef = "@string_t_ref"
-------------------------------------------------- * STG Closures in Mu
closureTag :: TypedefName
closureTag = "@_closure_tag"
-- | A tagged reference to a closure.
closureTR :: TypedefName
closureTR = "@_closure_tagref"
-- | A short field used to store things like the number of elements and the
-- partial-application status of the function.
muClosureMetadata :: TypedefName
muClosureMetadata = "@_closure_metadata"
-- | The Mu closure itself.
muClosure :: TypedefName
muClosure = "@_closure"
muClosureRef :: TypedefName
muClosureRef = "@_closure_ref"
muClosureFunctionSig :: SignatureName
......@@ -355,14 +374,20 @@ muClosureFunction = "@_closure_function"
haskellData :: TypedefName
haskellData = "@_haskell_data"
-- | An instruction to extract the entry function from a closure.
getClosureEntry :: VarName -> Expression
getClosureEntry = GetFieldIRef False muClosure 0
-- | An instruction to extract the tag from a closure.
getClosureTag :: VarName -> Expression
getClosureTag = GetFieldIRef False muClosure 1
-- | An instruction to extract the a particular field from a closure.
getClosureField :: VarName -> ClosureField -> Expression
getClosureField n field = GetFieldIRef False muClosure (fromEnum field) n
-- | An instruction to to get the data part from a closure.
getClosureData :: VarName -> Expression
getClosureData = GetVarPartIRef False muClosure
-- | An enumeration which corresponds to the position of the fields of Mu
-- closures.
data ClosureField = EntryField
| TagField
| NArgsField
deriving Enum
fieldIx :: ClosureField -> C.CInt
fieldIx = fromIntegral . fromEnum
......@@ -18,7 +18,7 @@ module Compiler.Mu.FromSTG
) where
import Control.Monad (void)
import Control.Monad (void, when)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Data.Char (ord)
import Data.String (fromString)
......@@ -31,7 +31,7 @@ import Outputable (Outputable, pprTraceIt)
import Language.Haskell.GHC.Simple (ModMetadata(..))
import GHC (ModSummary(..))
import DynFlags (DynFlags)
import TyCon (TyCon)
import TyCon (TyCon, isEnumerationTyCon, tyConDataCons)
import StgSyn
(StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg,
GenStgArg(..), StgExpr, GenStgExpr(..), UpdateFlag(..))
......@@ -48,24 +48,46 @@ import Debug.Trace
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
mapM_ codegenTopTypes tyCons
-- mapM_ codegenTopTypes tyCons
-- | Generate code for a top-level STG binding in Mu.
codegenTop :: StgBinding -> Mu ()
codegenTop binding =
case binding of
StgNonRec bindId rhs -> codegenTop' bindId rhs
StgRec pairs -> unzipWith codegenTop' pairs
where unzipWith f = mapM_ (uncurry f)
codegenTop binding = case binding of
StgNonRec bindId rhs -> codegenTop' bindId rhs
StgRec pairs -> unzipWith codegenTop' pairs
where unzipWith f = mapM_ (uncurry f)
codegenTopTypes :: TyCon -> Mu ()
codegenTopTypes tycon = do
when (isEnumerationTyCon tycon) $ codegenEnumerations tycon
mapM_ codegenDataCon (tyConDataCons tycon)
-- | Generate the static reference code for the entries of enumerated data types
codegenEnumerations :: TyCon -> Mu ()
codegenEnumerations _tycon = return ()
-- not sure if we need this
-- mapM_ go (tyConDataCons tycon)
-- | Generate the static closures for data constructor fields
codegenDataCon :: DataCon -> Mu ()
codegenDataCon dcon = do
traceShowM ("data con entry", (dataConEntry dcon))
closure dcon [] $ do
funcdef funcName (Version "1") muClosureFunctionSig $ do
return $ BasicBlock bbName [(paramName, muClosureRef)] Nothing
[]
(Return [paramName])
return funcName
where
funcName = dataConEntry dcon
bbName = funcName `subName` "entry"
paramName = bbName `subName` "param"
retVal = bbName `subName` "ret"
-------------------------------------------------- Utilities
......@@ -97,11 +119,12 @@ codegenTop' name rhs = case rhs of
closure name [] $ closureBody name vars body
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
[[retVal] := GetFieldIRef False muClosure 2 paramName]
(Return [retVal])
[]
(Return [paramName])
return funcName
where
funcName = entryNameOf name
......
......@@ -17,18 +17,17 @@ module Compiler.Mu.PrimOps
( loadPrim
) where
import Data.String (fromString)
import Compiler.Mu.CodeGen
import Mu.AST
loadPrim :: MuResult
loadPrim = bundleMu $ do
stub "@zdghczmprimzdGHCziTypeszdModule_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTyCon_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameS_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameD_static_entry"
return ()
-- stub "@zdghczmprimzdGHCziTypeszdModule_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTyCon_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTrNameS_static_entry"
-- stub "@zdghczmprimzdGHCziTypeszdTrNameD_static_entry"
stub :: FunctionName -> Mu ()
......@@ -38,8 +37,8 @@ stub n = primfuncdef n (placeholderBlocks n)
placeholderBlocks :: FunctionName -> Blocks BasicBlock
placeholderBlocks n =
return $ BasicBlock bbName [(param, muClosureRef)] Nothing
[[retVal] := getClosureTag param]
(Return [retVal])
[]
(Return [param])
where
bbName = n `subName` "entry"
param = bbName `subName` "param"
......
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