Commit 3581dc25 authored by nathyong's avatar nathyong

Add preliminary support for type constructors

parent 7370e42a
......@@ -28,6 +28,9 @@ module Compiler.Mu.CodeGen
-- * Block building monad
, Blocks
, runBlocks
, basicBlock
, assign
, upValue
-- * Code generation
, UnboxedData (..)
, bundleMu
......@@ -41,7 +44,6 @@ module Compiler.Mu.CodeGen
, closure
, string
-- * Naming interface
, tyconClosureName
, dataConEntry
, closureNameOf
, entryNameOf
......@@ -62,9 +64,11 @@ module Compiler.Mu.CodeGen
, ClosureField (..)
) where
import Control.Monad.Trans (MonadTrans, lift)
import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (State, StateT, MonadState, evalState, runStateT, gets)
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
import Data.Binary (Binary)
import Data.Foldable (toList, foldl')
import Data.List (genericLength)
......@@ -139,7 +143,7 @@ runMu :: Mu a -> a
runMu (Mu code) = evalState code $ MuState 0 mempty mempty ()
data MuState = MuState
{ _uniqueID :: Int
{ _uniqueID :: !Int
, _definitions :: Seq Definition
, _topLevels :: Seq TopLevel
, _currentBlock :: ()
......@@ -156,12 +160,51 @@ makeLenses ''BlockState
newtype Blocks a = Blocks (StateT BlockState Mu a)
deriving (Functor, Applicative, Monad, MonadState BlockState)
type BlocksWriter = WriterT [Assigned Expression] Blocks
runBlocks :: Blocks a -> Mu (a, Seq BasicBlock)
runBlocks (Blocks code) = do
(a, bstate) <- runStateT code $ BlockState mempty
-- TODO: allocate upvalues
return (a, _blocks bstate)
-- | Lift a 'Mu' computation into the Blocks monad.
liftBlocks :: Mu a -> Blocks a
liftBlocks m = Blocks (lift m)
-- | Emit a basic block without an exceptional parameter.
basicBlock
:: BasicBlockName
-> [(VarName, TypedefName)]
-> BlocksWriter Expression
-> Blocks BasicBlock
basicBlock n params exprs = do
(terminator, body) <- runWriterT exprs
return $ BasicBlock n params Nothing body terminator
where
-- | Assign the result of a Mu 'Expression' to a 'VarName'.
assign :: Expression -> BlocksWriter VarName
assign expr = do
uid <- lift $ liftBlocks nextMuUnique
let n = fromString ("var" ++ show uid)
tell $ [[n] := expr]
return n
-- | Declare a (constant) value to be defined at the top level.
upValue :: ConstConstructor -> TypedefName -> BlocksWriter ConstantName
upValue ctor ty = lift . liftBlocks $ do
uid <- nextMuUnique
let n = fromString ("@upvar" ++ show uid)
constant n ty ctor
return n
-------------------------------------------------- * Code generation
-- | Extract the definitions and other useful things from the Mu monad.
......@@ -244,6 +287,13 @@ populate ctx top = case top of
-------------------------------------------------- * Mu interface
-- | Get a unique number from the Mu monad.
nextMuUnique :: Mu Int
nextMuUnique = do
currentID <- gets _uniqueID
uniqueID %= (+1)
return currentID
-- | Emit a closure with a payload and an entry function. The closure itself
-- will be allocated during build time.
closure :: (Uniquable a, NamedThing a)
......@@ -260,9 +310,8 @@ closure name payload code = do
string :: GHC.Id -> B.ByteString -> Mu GlobalCellName
string name bytes = do
name' <- do
currentID <- gets _uniqueID
uniqueID %= (+1)
return $ fromString $ stringify name <> "_str" <> show currentID
uid <- nextMuUnique
return $ fromString $ stringify name <> "_str" <> show uid
definitions %= (|> GlobalCell name' muStringRef)
topLevels %= (|> ByteArray name' bytes)
return name'
......@@ -305,9 +354,6 @@ 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"
......
......@@ -49,7 +49,7 @@ stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do
loadTypes
mapM_ codegenTop bindings
mapM_ codegenTopTypes tyCons
mapM_ codegenType tyCons
-- | Generate code for a top-level STG binding in Mu.
......@@ -60,34 +60,46 @@ codegenTop binding = case binding of
where unzipWith f = mapM_ (uncurry f)
codegenTopTypes :: TyCon -> Mu ()
codegenTopTypes tycon = do
-- | Generate code for a type.
codegenType :: TyCon -> Mu ()
codegenType tycon = do
when (isEnumerationTyCon tycon) $ codegenEnumerations tycon
mapM_ codegenDataCon (tyConDataCons tycon)
-- | Generate the static reference code for the entries of enumerated data types
-- | Generate the static reference code for the entries of enumerated data
-- types.
codegenEnumerations :: TyCon -> Mu ()
codegenEnumerations _tycon = return ()
-- not sure if we need this
-- TODO: not sure if we need this
-- mapM_ go (tyConDataCons tycon)
-- | Generate the static closures for data constructor fields
-- | 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])
_ <- basicBlock mkClosure
[(mkClosure `dot` "ref", muClosureRef)] $ do
-- TODO: allocate the length of the closure cleanly
cLen <- upValue (IntCtor 7) i64
c <- assign $ NewHybrid muClosure i64 (VarName $ toName cLen) Nothing
cRef <- assign $ GetIRef muClosure c
return $ Return [cRef]
basicBlock entry
[(paramName, muClosureRef)] $ do
return $ Return [paramName]
return funcName
where
funcName = dataConEntry dcon
bbName = funcName `subName` "entry"
paramName = bbName `subName` "param"
retVal = bbName `subName` "ret"
entry = funcName `dot` "entry"
mkClosure = funcName `dot` "mkClosure"
paramName = entry `dot` "param"
-------------------------------------------------- Utilities
......@@ -128,9 +140,9 @@ closureBody name vars body = do
return funcName
where
funcName = entryNameOf name
bbName = funcName `subName` "entry"
paramName = bbName `subName` "param"
retVal = bbName `subName` "ret"
bbName = funcName `dot` "entry"
paramName = bbName `dot` "param"
retVal = bbName `dot` "ret"
......
......@@ -40,6 +40,6 @@ placeholderBlocks n =
[]
(Return [param])
where
bbName = n `subName` "entry"
param = bbName `subName` "param"
retVal = bbName `subName` "ret"
bbName = n `dot` "entry"
param = bbName `dot` "param"
retVal = bbName `dot` "ret"
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