Commit 3581dc25 authored by nathyong's avatar nathyong

Add preliminary support for type constructors

parent 7370e42a
...@@ -28,6 +28,9 @@ module Compiler.Mu.CodeGen ...@@ -28,6 +28,9 @@ module Compiler.Mu.CodeGen
-- * Block building monad -- * Block building monad
, Blocks , Blocks
, runBlocks , runBlocks
, basicBlock
, assign
, upValue
-- * Code generation -- * Code generation
, UnboxedData (..) , UnboxedData (..)
, bundleMu , bundleMu
...@@ -41,7 +44,6 @@ module Compiler.Mu.CodeGen ...@@ -41,7 +44,6 @@ module Compiler.Mu.CodeGen
, closure , closure
, string , string
-- * Naming interface -- * Naming interface
, tyconClosureName
, dataConEntry , dataConEntry
, closureNameOf , closureNameOf
, entryNameOf , entryNameOf
...@@ -62,9 +64,11 @@ module Compiler.Mu.CodeGen ...@@ -62,9 +64,11 @@ module Compiler.Mu.CodeGen
, ClosureField (..) , ClosureField (..)
) where ) where
import Control.Monad.Trans (MonadTrans, lift)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (State, StateT, MonadState, evalState, runStateT, gets) 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.Binary (Binary)
import Data.Foldable (toList, foldl') import Data.Foldable (toList, foldl')
import Data.List (genericLength) import Data.List (genericLength)
...@@ -139,7 +143,7 @@ runMu :: Mu a -> a ...@@ -139,7 +143,7 @@ runMu :: Mu a -> a
runMu (Mu code) = evalState code $ MuState 0 mempty mempty () runMu (Mu code) = evalState code $ MuState 0 mempty mempty ()
data MuState = MuState data MuState = MuState
{ _uniqueID :: Int { _uniqueID :: !Int
, _definitions :: Seq Definition , _definitions :: Seq Definition
, _topLevels :: Seq TopLevel , _topLevels :: Seq TopLevel
, _currentBlock :: () , _currentBlock :: ()
...@@ -156,12 +160,51 @@ makeLenses ''BlockState ...@@ -156,12 +160,51 @@ makeLenses ''BlockState
newtype Blocks a = Blocks (StateT BlockState Mu a) newtype Blocks a = Blocks (StateT BlockState Mu a)
deriving (Functor, Applicative, Monad, MonadState BlockState) deriving (Functor, Applicative, Monad, MonadState BlockState)
type BlocksWriter = WriterT [Assigned Expression] Blocks
runBlocks :: Blocks a -> Mu (a, Seq BasicBlock) runBlocks :: Blocks a -> Mu (a, Seq BasicBlock)
runBlocks (Blocks code) = do runBlocks (Blocks code) = do
(a, bstate) <- runStateT code $ BlockState mempty (a, bstate) <- runStateT code $ BlockState mempty
-- TODO: allocate upvalues
return (a, _blocks bstate) 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 -------------------------------------------------- * Code generation
-- | Extract the definitions and other useful things from the Mu monad. -- | Extract the definitions and other useful things from the Mu monad.
...@@ -244,6 +287,13 @@ populate ctx top = case top of ...@@ -244,6 +287,13 @@ populate ctx top = case top of
-------------------------------------------------- * Mu interface -------------------------------------------------- * 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 -- | Emit a closure with a payload and an entry function. The closure itself
-- will be allocated during build time. -- will be allocated during build time.
closure :: (Uniquable a, NamedThing a) closure :: (Uniquable a, NamedThing a)
...@@ -260,9 +310,8 @@ closure name payload code = do ...@@ -260,9 +310,8 @@ closure name payload code = do
string :: GHC.Id -> B.ByteString -> Mu GlobalCellName string :: GHC.Id -> B.ByteString -> Mu GlobalCellName
string name bytes = do string name bytes = do
name' <- do name' <- do
currentID <- gets _uniqueID uid <- nextMuUnique
uniqueID %= (+1) return $ fromString $ stringify name <> "_str" <> show uid
return $ fromString $ stringify name <> "_str" <> show currentID
definitions %= (|> GlobalCell name' muStringRef) definitions %= (|> GlobalCell name' muStringRef)
topLevels %= (|> ByteArray name' bytes) topLevels %= (|> ByteArray name' bytes)
return name' return name'
...@@ -305,9 +354,6 @@ stringify a ...@@ -305,9 +354,6 @@ stringify a
stableName = zString . zEncodeFS . fsLit . nameStableString stableName = zString . zEncodeFS . fsLit . nameStableString
uniquePart = show . getUnique uniquePart = show . getUnique
tyconClosureName :: GHC.TyCon -> GlobalCellName
tyconClosureName n = GlobalCellName $ Name $ stringify n <> "_closure"
dataConEntry :: GHC.DataCon -> FunctionName dataConEntry :: GHC.DataCon -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry" dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"
......
...@@ -49,7 +49,7 @@ stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult ...@@ -49,7 +49,7 @@ stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do stgToMu modData (tyCons, bindings) = bundleMu $ do
loadTypes loadTypes
mapM_ codegenTop bindings mapM_ codegenTop bindings
mapM_ codegenTopTypes tyCons mapM_ codegenType tyCons
-- | Generate code for a top-level STG binding in Mu. -- | Generate code for a top-level STG binding in Mu.
...@@ -60,34 +60,46 @@ codegenTop binding = case binding of ...@@ -60,34 +60,46 @@ codegenTop binding = case binding of
where unzipWith f = mapM_ (uncurry f) where unzipWith f = mapM_ (uncurry f)
codegenTopTypes :: TyCon -> Mu () -- | Generate code for a type.
codegenTopTypes tycon = do codegenType :: TyCon -> Mu ()
codegenType tycon = do
when (isEnumerationTyCon tycon) $ codegenEnumerations tycon when (isEnumerationTyCon tycon) $ codegenEnumerations tycon
mapM_ codegenDataCon (tyConDataCons 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 -> Mu ()
codegenEnumerations _tycon = return () codegenEnumerations _tycon = return ()
-- not sure if we need this -- TODO: not sure if we need this
-- mapM_ go (tyConDataCons tycon) -- mapM_ go (tyConDataCons tycon)
-- | Generate the static closures for data constructor fields -- | Generate the static closures for data constructor fields.
codegenDataCon :: DataCon -> Mu () codegenDataCon :: DataCon -> Mu ()
codegenDataCon dcon = do codegenDataCon dcon = do
traceShowM ("data con entry", (dataConEntry dcon)) traceShowM ("data con entry", (dataConEntry dcon))
closure dcon [] $ do closure dcon [] $ do
funcdef funcName (Version "1") muClosureFunctionSig $ do funcdef funcName (Version "1") muClosureFunctionSig $ do
return $ BasicBlock bbName [(paramName, muClosureRef)] Nothing
[] _ <- basicBlock mkClosure
(Return [paramName]) [(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 return funcName
where where
funcName = dataConEntry dcon funcName = dataConEntry dcon
bbName = funcName `subName` "entry" entry = funcName `dot` "entry"
paramName = bbName `subName` "param" mkClosure = funcName `dot` "mkClosure"
retVal = bbName `subName` "ret" paramName = entry `dot` "param"
-------------------------------------------------- Utilities -------------------------------------------------- Utilities
...@@ -128,9 +140,9 @@ closureBody name vars body = do ...@@ -128,9 +140,9 @@ closureBody name vars body = do
return funcName return funcName
where where
funcName = entryNameOf name funcName = entryNameOf name
bbName = funcName `subName` "entry" bbName = funcName `dot` "entry"
paramName = bbName `subName` "param" paramName = bbName `dot` "param"
retVal = bbName `subName` "ret" retVal = bbName `dot` "ret"
......
...@@ -40,6 +40,6 @@ placeholderBlocks n = ...@@ -40,6 +40,6 @@ placeholderBlocks n =
[] []
(Return [param]) (Return [param])
where where
bbName = n `subName` "entry" bbName = n `dot` "entry"
param = bbName `subName` "param" param = bbName `dot` "param"
retVal = bbName `subName` "ret" 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