Commit b8a4abf4 authored by nathyong's avatar nathyong

Implement creation of data types with tags

parent 0bbe7fff
Pipeline #4 failed with stage
in 8 minutes and 54 seconds
...@@ -30,6 +30,8 @@ module Compiler.Mu.CodeGen ...@@ -30,6 +30,8 @@ module Compiler.Mu.CodeGen
, runBlocks , runBlocks
, basicBlock , basicBlock
, assign , assign
, emit
, upTag
, upValue , upValue
-- * Code generation -- * Code generation
, UnboxedData (..) , UnboxedData (..)
...@@ -56,6 +58,8 @@ module Compiler.Mu.CodeGen ...@@ -56,6 +58,8 @@ module Compiler.Mu.CodeGen
, closureTR , closureTR
, muClosure , muClosure
, muClosureRef , muClosureRef
, muClosureMetadata
, muClosureTag
, muClosureFunction , muClosureFunction
, muClosureFunctionSig , muClosureFunctionSig
, haskellData , haskellData
...@@ -166,7 +170,6 @@ type BlocksWriter = WriterT [Assigned Expression] Blocks ...@@ -166,7 +170,6 @@ 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)
...@@ -191,18 +194,32 @@ basicBlock n params exprs = do ...@@ -191,18 +194,32 @@ basicBlock n params exprs = do
assign :: Expression -> BlocksWriter VarName assign :: Expression -> BlocksWriter VarName
assign expr = do assign expr = do
uid <- lift $ liftBlocks nextMuUnique uid <- lift $ liftBlocks nextMuUnique
let n = fromString ("var" ++ show uid) let n = fromString ("@var" ++ show uid)
tell $ [[n] := expr] tell $ [[n] := expr]
return n return n
-- | Run a Mu 'Expression' without binding to anything.
emit :: Expression -> BlocksWriter ()
emit expr = tell $ [[] := expr]
-- | Declare a (constant) tag to be defined at the top level, without
-- clobbering any other upvalues.
upTag :: Int -> BlocksWriter VarName
upTag i = lift . liftBlocks $ do
let n = fromString ("@tag_const_" ++ show i)
constant n muClosureTag (IntCtor (fromIntegral i))
return (VarName $ toName n)
-- | Declare a (constant) value to be defined at the top level. -- | Declare a (constant) value to be defined at the top level.
upValue :: ConstConstructor -> TypedefName -> BlocksWriter ConstantName upValue :: ConstConstructor -> TypedefName -> BlocksWriter VarName
upValue ctor ty = lift . liftBlocks $ do upValue ctor ty = lift . liftBlocks $ do
uid <- nextMuUnique uid <- nextMuUnique
let n = fromString ("@upvar" ++ show uid) let n = fromString ("@upvar" ++ show uid)
constant n ty ctor constant n ty ctor
return n return (VarName $ toName n)
-------------------------------------------------- * Code generation -------------------------------------------------- * Code generation
...@@ -379,6 +396,7 @@ loadTypes = do ...@@ -379,6 +396,7 @@ loadTypes = do
typedef muString $ Hybrid [] i8 typedef muString $ Hybrid [] i8
typedef muStringRef $ Ref muString typedef muStringRef $ Ref muString
typedef muClosureMetadata $ MuInt 8 typedef muClosureMetadata $ MuInt 8
typedef muClosureTag $ MuInt 6
typedef muClosureFunction $ FuncRef muClosureFunctionSig typedef muClosureFunction $ FuncRef muClosureFunctionSig
typedef muClosure $ typedef muClosure $
Hybrid [muClosureFunction, muClosureMetadata, muClosureMetadata] Hybrid [muClosureFunction, muClosureMetadata, muClosureMetadata]
...@@ -407,6 +425,10 @@ closureTR = "@_closure_tagref" ...@@ -407,6 +425,10 @@ closureTR = "@_closure_tagref"
muClosureMetadata :: TypedefName muClosureMetadata :: TypedefName
muClosureMetadata = "@_closure_metadata" muClosureMetadata = "@_closure_metadata"
-- | A tag that can be put on the end of a tagged reference.
muClosureTag :: TypedefName
muClosureTag = "@_closure_tag"
-- | The Mu closure itself. -- | The Mu closure itself.
muClosure :: TypedefName muClosure :: TypedefName
muClosure = "@_closure" muClosure = "@_closure"
......
...@@ -25,7 +25,7 @@ import Data.String (fromString) ...@@ -25,7 +25,7 @@ import Data.String (fromString)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Literal (Literal(..)) import Literal (Literal(..))
import DataCon (DataCon, dataConWrapId) import DataCon (DataCon, dataConWrapId, dataConRepRepArity, dataConTag)
import BasicTypes (RecFlag(..)) import BasicTypes (RecFlag(..))
import Outputable (Outputable, pprTraceIt) import Outputable (Outputable, pprTraceIt)
import Language.Haskell.GHC.Simple (ModMetadata(..)) import Language.Haskell.GHC.Simple (ModMetadata(..))
...@@ -78,28 +78,22 @@ codegenEnumerations _tycon = return () ...@@ -78,28 +78,22 @@ codegenEnumerations _tycon = return ()
-- | 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 static entry", (dataConEntry dcon))
closure dcon [] $ do closure dcon [] $ do
funcdef funcName (Version "1") muClosureFunctionSig $ do -- The undersaturated and exact application cases are exactly the same,
-- just return the same closure with the arity updated
_ <- basicBlock mkClosure funcdef funcName (Version "1") muClosureFunctionSig $
[(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 basicBlock entry
[(paramName, muClosureRef)] $ do [(this, muClosureRef)] $ do
return $ Return [paramName] tag <- upTag (dataConTag dcon)
ref <- assign $ Comminst CiUvmTr64FromRef [] [] [this, tag] Nothing Nothing
return $ Return [ref]
return funcName return funcName
where where
funcName = dataConEntry dcon funcName = dataConEntry dcon
entry = funcName `dot` "entry" entry = funcName `dot` "entry"
mkClosure = funcName `dot` "mkClosure" exact = funcName `dot` "exact"
paramName = entry `dot` "param" this = entry `dot` "this"
-------------------------------------------------- Utilities -------------------------------------------------- Utilities
......
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