GitLab will be upgraded to the 12.10.14-ce.0 on 28 Sept 2020 at 2.00pm (AEDT) to 2.30pm (AEDT). During the update, GitLab and Mattermost services will not be available. If you have any concerns with this, please talk to us at N110 (b) CSIT building.

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