Commit 4e3377a2 authored by nathyong's avatar nathyong

Implement variable capturing

parent 70a4766e
Pipeline #5 failed with stage
in 4 minutes and 45 seconds
......@@ -16,8 +16,9 @@ cabal-version: >=1.10
library
hs-source-dirs: src
other-extensions:
TemplateHaskell,
GeneralizedNewtypeDeriving
GeneralizedNewtypeDeriving,
OverloadedStrings,
DeriveGeneric
ghc-options: -Wall
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
......@@ -48,7 +49,6 @@ executable anuhc-exe
, mu
, mu-pure
, containers
, directory
, ghc-simple
, text
default-language: Haskell2010
......
......@@ -43,14 +43,14 @@ compilerConfig =
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = ["-ddump-stg", "-ddump-cmm-raw", "-ddump-to-file"] {-"-v5",-}
, cfgCacheDirectory = Just "/tmp/"
, cfgCacheDirectory = Just "/tmp/anuhc/"
}
main :: IO ()
main = do
inputFiles <- getArgs
b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles
libresults <- mapM compileLibraryFiles libraryFiles
libresults <- return [] -- mapM compileLibraryFiles libraryFiles
case b of
Success results _ _ -> do
doResults lives $ mergeResults $ (loadPrim : concat libresults ++ results')
......@@ -60,8 +60,8 @@ main = do
getDefns (defns, _, _) = fmap toName defns
Failure _ _ -> exitFailure
compileLibraryFiles :: (String, [FilePath]) -> IO [MuResult]
compileLibraryFiles (packageKey, files) = do
compileLibraryFiles :: (String, [FilePath], [String]) -> IO [MuResult]
compileLibraryFiles (packageKey, files, extraFlags) = do
traceM ("Compiling the library file " ++ packageKey)
b <- GHC.Simple.compileWith libconfig compileMu files
case b of
......@@ -70,7 +70,9 @@ compileLibraryFiles (packageKey, files) = do
where
libconfig = compilerConfig
{ cfgGhcFlags =
["-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"]
[ "-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"
, "-I/Users/nathan/projects/microvm/anuhc/libraries/include/"]
++ extraFlags
}
doResults :: [Name] -> MuMergedResult -> IO ()
......@@ -97,9 +99,9 @@ doResults liveObjectNames (defns, topClosures, mainFunction) = do
-- | A list of all library files, indexed by their package-key.
-- TODO: fix this.
libraryFiles :: [(String, [FilePath])]
libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles)
, ("base", prefix baseFiles)
libraryFiles :: [(String, [FilePath], [String])]
libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles, [])
, ("base", prefix baseFiles, ["-I/Users/nathan/projects/microvm/anuhc/libraries/base/include/", "-i/Users/nathan/projects/microvm/anuhc/libraries/base"])
]
where
prefix = fmap ("/Users/nathan/projects/microvm/anuhc/libraries/" ++)
......
......@@ -10,10 +10,10 @@
-- Utility functions for Haskell code generation via Mu.
--
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Mu.CodeGen
( -- * Mu Monad
......@@ -21,17 +21,26 @@ module Compiler.Mu.CodeGen
, runMu
, definitions
, topLevels
, currentBlock
, MuResult
, MuMergedResult
, mergeResults
-- * Block building monad
, Blocks
, CapturedIDs
, sortedIDs
, sortedIDNames
, BasicBlocks
, ExpWriter
, runBlocks
, capturing
, lookupID
, basicBlock
, paramsFor
, assign
, emit
, emitBB
, upTag
, upConstant
, upValue
-- * Code generation
, UnboxedData (..)
......@@ -66,12 +75,15 @@ module Compiler.Mu.CodeGen
, getClosureField
, getClosureData
, ClosureField (..)
-- * Utility functions
, isInternal
) 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.Reader (Reader, ReaderT, MonadReader, runReaderT, ask, local, reader)
import Control.Monad.State.Strict (State, StateT, MonadState, evalState, runStateT, gets)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
import Data.Binary (Binary)
import Data.Foldable (toList, foldl')
......@@ -82,11 +94,13 @@ import Data.Sequence (Seq, (|>))
import Data.String (fromString)
import GHC.Generics (Generic)
import qualified Data.ByteString as B
import qualified Data.Sequence as S
import qualified Data.Map.Strict as M
import qualified Foreign as F
import qualified Foreign.C as C
import Lens.Micro.Platform ((%=), makeLenses)
import Language.Haskell.GHC.Simple (ModMetadata(..), mmSummary)
import Lens.Micro.Platform ((%=), Lens')
import FastString (fsLit, zEncodeFS, zString)
import qualified GHC
......@@ -117,6 +131,7 @@ instance HasName TopLevel where
data UnboxedData = UnboxedInt Integer
| UnboxedDouble Rational
| TaggedPointer GlobalCellName Int
| NullPointer
deriving (Generic)
instance Binary UnboxedData
......@@ -143,81 +158,160 @@ newtype Mu a = Mu (State MuState a)
deriving (Functor, Applicative, Monad, MonadState MuState)
-- | Run a Mu computation from the empty state, storing the result.
runMu :: Mu a -> a
runMu (Mu code) = evalState code $ MuState 0 mempty mempty ()
runMu :: MuState -> Mu a -> a
runMu state (Mu code) = evalState code state
data MuState = MuState
{ _uniqueID :: !Int
, _moduleName :: String
, _definitions :: Seq Definition
, _topLevels :: Seq TopLevel
, _currentBlock :: ()
}
makeLenses ''MuState
uniqueID :: Lens' MuState Int
uniqueID k m = fmap (\new -> m { _uniqueID = new }) (k (_uniqueID m))
moduleName :: Lens' MuState String
moduleName k m = fmap (\new -> m { _moduleName = new }) (k (_moduleName m))
definitions :: Lens' MuState (Seq Definition)
definitions k m = fmap (\new -> m { _definitions = new }) (k (_definitions m))
topLevels :: Lens' MuState (Seq TopLevel)
topLevels k m = fmap (\new -> m { _topLevels = new }) (k (_topLevels m))
-------------------------------------------------- * Block building monad
data BlockState = BlockState { _blocks :: Seq BasicBlock }
-- | Read only state for building blocks.
type CapturedIDs = Map GHC.Id VarName
sortedIDs :: CapturedIDs -> [GHC.Id]
sortedIDs mapping = fmap fst $ M.toAscList mapping
-- | Mutable state for the block building monad
type BasicBlocks = Seq BasicBlock
makeLenses ''BlockState
-- | An environment for outputing individual instructions.
type ExpWriter = WriterT [Assigned Expression] Blocks
newtype Blocks a = Blocks (StateT BlockState Mu a)
deriving (Functor, Applicative, Monad, MonadState BlockState)
type BlocksWriter = WriterT [Assigned Expression] Blocks
-- | A monad for all of the state involved when building a function. This
-- includes the basic blocks and their instructions, as well as the captured
-- variables inside a particular function.
newtype Blocks a = Blocks (ReaderT CapturedIDs (WriterT BasicBlocks Mu) a)
deriving (Functor, Applicative, Monad, MonadWriter BasicBlocks, MonadReader CapturedIDs)
runBlocks :: Blocks a -> Mu (a, Seq BasicBlock)
runBlocks (Blocks code) = do
(a, bstate) <- runStateT code $ BlockState mempty
return (a, _blocks bstate)
runBlocks :: CapturedIDs -> Blocks a -> Mu (a, BasicBlocks)
runBlocks r (Blocks code) = do
(a, bbs) <- runWriterT (runReaderT code r)
traceShowM $ ("There are ", S.length bbs, " basic blocks")
return (a, bbs)
-- | Lift a 'Mu' computation into the Blocks monad.
-- | Run a 'Blocks' computation inside a local environment capturing extra
-- variables.
capturing :: MonadReader CapturedIDs m
=> m a -- ^ Computation to run
-> Map GHC.Id VarName -- ^ Extra variables to capture
-> m a
capturing b r = local (M.union r) b
sortedIDNames :: MonadReader CapturedIDs m => m [VarName]
sortedIDNames = ask >>= return . fmap snd . M.toAscList
-- | Obtain the 'VarName' for a particular 'GHC.Id' in the current mapping. If
-- it does not exist, crash and burn spectacularly.
lookupID :: GHC.Id -> ExpWriter VarName
lookupID i = lift $ do
n <- reader (M.lookup i)
case n of
Nothing -> error ("lookupID: could not find " ++ stringify i)
Just n' -> return n'
-- | Lift a 'Mu' computation into the 'Blocks' monad.
liftBlocks :: Mu a -> Blocks a
liftBlocks m = Blocks (lift m)
liftBlocks m = Blocks (lift . lift $ m)
-- | Emit a basic block without an exceptional parameter.
basicBlock
:: BasicBlockName
-> [(VarName, TypedefName)]
-> BlocksWriter Expression
:: BasicBlockName -- ^ Name of the block itself
-> [(VarName, TypedefName)] -- ^ Parameters of the block, and their types
-> ExpWriter Expression -- ^ Code to generate expressions within the block
-> Blocks BasicBlock
basicBlock n params exprs = do
(terminator, body) <- runWriterT exprs
return $ BasicBlock n params Nothing body terminator
bindings <- ask
(terminator, body) <- runWriterT exprs `capturing` newMappings n bindings
return $ BasicBlock n (params ++ paramsFor n bindings) Nothing body terminator
-- | Generate a new mapping for
newMappings :: BasicBlockName
-> Map GHC.Id a
-> CapturedIDs
newMappings block mapping = M.mapWithKey genParam mapping
where
genParam i _ = block `dot` tail (stringify i)
-- | Obtain a list of variables and their types
paramsFor :: BasicBlockName
-> Map GHC.Id a
-> [(VarName, TypedefName)]
paramsFor block mapping = fmap pairUp (M.toAscList mapping)
where
pairUp (i, _) = (block `dot` tail (stringify i), haskellData)
-- | Assign the result of a Mu 'Expression' to a 'VarName'.
assign :: Expression -> BlocksWriter VarName
assign :: Expression -> ExpWriter VarName
assign expr = do
uid <- lift $ liftBlocks nextMuUnique
let n = fromString ("@var" ++ show uid)
tell $ [[n] := expr]
let n = fromString ("@var" ++ uid)
emit' $ [n] := expr
return n
-- | Run a Mu 'Expression' without binding to anything.
emit :: Expression -> BlocksWriter ()
emit expr = tell $ [[] := expr]
emit :: Expression -> ExpWriter ()
emit expr = emit' $ [] := expr
emit' :: Assigned Expression -> ExpWriter ()
emit' = tell . pure
emitBB :: BasicBlock -> Blocks ()
emitBB = tell . pure
-- | Declare a (constant) tag to be defined at the top level, without
-- clobbering any other upvalues.
upTag :: Int -> BlocksWriter VarName
upTag :: Int -> ExpWriter VarName
upTag i = lift . liftBlocks $ do
let n = fromString ("@tag_const_" ++ show i)
constant n muClosureTag (IntCtor (fromIntegral i))
return (VarName $ toName n)
-- | Declare an integer constant to be defined at the top level, without
-- clobbering any other upvalues.
upConstant :: Int -> ExpWriter VarName
upConstant i = lift . liftBlocks $ do
let n = fromString ("@i64_" ++ show i)
constant n i64 (IntCtor (fromIntegral i))
return (VarName $ toName n)
-- | Declare a (constant) value to be defined at the top level.
upValue :: ConstConstructor -> TypedefName -> BlocksWriter VarName
upValue :: ConstConstructor -> TypedefName -> ExpWriter VarName
upValue ctor ty = lift . liftBlocks $ do
uid <- nextMuUnique
let n = fromString ("@upvar" ++ show uid)
let n = fromString ("@upvar" ++ uid)
constant n ty ctor
return (VarName $ toName n)
......@@ -225,12 +319,14 @@ upValue ctor ty = lift . liftBlocks $ do
-------------------------------------------------- * Code generation
-- | Extract the definitions and other useful things from the Mu monad.
bundleMu :: Mu () -> MuResult
bundleMu codegen = runMu $ do
bundleMu :: String -> Mu () -> MuResult
bundleMu modName codegen = runMu initialState $ do
codegen
defns <- gets _definitions
tops <- gets _topLevels
return (defns, tops, Nothing)
where
initialState = MuState 0 modName mempty mempty
-- | Populate a Mu Closure, or other top-level data type, at build-time.
......@@ -277,6 +373,13 @@ populate ctx top = case top of
cellRef <- ctxLoad ctx muOrdNotAtomic cellHandle
trCellRef <- tr64FromRef ctx cellRef tag'
store ctx muOrdNotAtomic ref trCellRef
NullPointer -> do
tag' <- handleFromSint64 ctx 0 6
reftyID <- getID ctx muClosureRef
nullRef <- handleFromPtr ctx reftyID F.nullPtr
trNull <- tr64FromRef ctx nullRef tag'
store ctx muOrdNotAtomic ref trNull
shiftIref ctx ref one >>= storePayloads ds
storePayloads payload closureDataRef
......@@ -304,12 +407,13 @@ populate ctx top = case top of
-------------------------------------------------- * Mu interface
-- | Get a unique number from the Mu monad.
nextMuUnique :: Mu Int
-- | Get a unique identifier (name) from the Mu monad.
nextMuUnique :: Mu String
nextMuUnique = do
currentID <- gets _uniqueID
modName <- gets _moduleName
uniqueID %= (+1)
return currentID
return $ "_uq_" <> modName <> "_" <> show currentID
-- | Emit a closure with a payload and an entry function. The closure itself
-- will be allocated during build time.
......@@ -328,7 +432,7 @@ string :: GHC.Id -> B.ByteString -> Mu GlobalCellName
string name bytes = do
name' <- do
uid <- nextMuUnique
return $ fromString $ stringify name <> "_str" <> show uid
return $ fromString $ stringify name <> uid <> "_str"
definitions %= (|> GlobalCell name' muStringRef)
topLevels %= (|> ByteArray name' bytes)
return name'
......@@ -352,10 +456,57 @@ funcsig n argtys rettys = definitions %= (|> SignatureDefinition n argtys rettys
-- | Emit a function (version) definition.
funcdef :: FunctionName -> Version -> SignatureName -> Blocks BasicBlock -> Mu ()
funcdef n v sig body = do
(entry, bblocks) <- runBlocks body
(entry, bblocks) <- runBlocks M.empty body
traceBB entry
mapM_ traceBB bblocks
definitions %= (|> FunctionDefinition n v sig entry (toList bblocks))
traceBB :: Applicative m => BasicBlock -> m ()
traceBB bb@(BasicBlock n ps exc insts term) = traceShowM (n, fmap sexp' insts, sexp term)
where
sexp' :: Assigned Expression -> String
sexp' (d := aexp) = show d ++ " := " ++ sexp aexp
sexp :: Expression -> String
sexp aexp = case aexp of
BinaryOperation {} -> "BinaryOperation"
CompareOperation {} -> "CompareOperation"
ConvertOperation {} -> "ConvertOperation"
AtomicRMWOperation {} -> "AtomicRMWOperation"
CmpXchg {} -> "CmpXchg"
Fence {} -> "Fence"
New {} -> "New"
NewHybrid {} -> "NewHybrid"
Alloca {} -> "Alloca"
AllocaHybrid {} -> "AllocaHybrid"
Return {} -> "Return"
Throw {} -> "Throw"
Call {} -> "Call"
CCall {} -> "CCall"
TailCall {} -> "TailCall"
Branch1 {} -> "Branch1"
Branch2 {} -> "Branch2"
WatchPoint {} -> "WatchPoint"
Trap {} -> "Trap"
WPBranch {} -> "WPBranch"
Switch {} -> "Switch"
SwapStack {} -> "SwapStack"
NewThread {} -> "NewThread"
Comminst {} -> "Comminst"
Load {} -> "Load"
Store {} -> "Store"
ExtractValue {} -> "ExtractValue"
InsertValue {} -> "InsertValue"
ExtractElement {} -> "ExtractElement"
InsertElement {} -> "InsertElement"
ShuffleVector {} -> "ShuffleVector"
GetIRef {} -> "GetIRef"
GetFieldIRef {} -> "GetFieldIRef"
GetElemIRef {} -> "GetElemIRef"
ShiftIRef {} -> "ShiftIRef"
GetVarPartIRef {} -> "GetVarPartIRef"
primfuncdef :: FunctionName -> Blocks BasicBlock -> Mu ()
primfuncdef n body = funcdef n (Version "1") muClosureFunctionSig body
......@@ -364,7 +515,8 @@ primfuncdef n body = funcdef n (Version "1") muClosureFunctionSig body
stringify :: (Uniquable a, NamedThing a) => a -> String
stringify a
| isSystemName name = '@':(stableName name <> "_" <> uniquePart a)
| isSystemName name || isInternalName name =
'@':(stableName name <> "_" <> uniquePart a)
| otherwise = '@':(stableName name)
where
name = getName a
......@@ -459,3 +611,9 @@ data ClosureField = EntryField
fieldIx :: ClosureField -> C.CInt
fieldIx = fromIntegral . fromEnum
-------------------------------------------------- * Utility functions
isInternal :: NamedThing a => a -> Bool
isInternal = isInternalName . getName
......@@ -18,14 +18,20 @@ module Compiler.Mu.FromSTG
) where
import Control.Monad (void, when)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Data.Map.Strict (Map)
import Control.Monad (void, when, foldM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (Reader, ReaderT, MonadReader, runReaderT, ask, local)
import Control.Monad.State.Strict (State, StateT, MonadState, evalState, runStateT, gets)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Monad.Writer (Writer, WriterT, MonadWriter, runWriterT, tell)
import Data.Char (ord)
import Data.String (fromString)
import Data.Monoid ((<>))
import qualified Data.Map.Strict as M
import Literal (Literal(..))
import DataCon (DataCon, dataConWrapId, dataConRepRepArity, dataConTag)
import DataCon (DataCon, dataConWrapId, dataConRepRepArity, dataConTag, isUnboxedTupleCon)
import BasicTypes (RecFlag(..))
import Outputable (Outputable, pprTraceIt)
import Language.Haskell.GHC.Simple (ModMetadata(..))
......@@ -38,6 +44,8 @@ import StgSyn
import qualified GHC as GHC
import qualified Literal as Lit
import qualified Var as Var
import Compiler.Mu.CodeGen
import Mu.AST
......@@ -46,10 +54,12 @@ import Debug.Trace
-- | Compile the information inside an STG module into a 'Bundle'.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do
stgToMu modData (tyCons, bindings) = bundleMu modName $ do
loadTypes
mapM_ codegenTop bindings
mapM_ codegenType tyCons
where
modName = traceShowId $ mmName modData
-- | Generate code for a top-level STG binding in Mu.
......@@ -78,7 +88,6 @@ codegenEnumerations _tycon = return ()
-- | Generate the static closures for data constructor fields.
codegenDataCon :: DataCon -> Mu ()
codegenDataCon dcon = do
traceShowM ("data con static entry", (dataConEntry dcon))
closure dcon [] $ do
-- The undersaturated and exact application cases are exactly the same,
-- just return the same closure with a tag
......@@ -91,7 +100,6 @@ codegenDataCon dcon = do
where
funcName = dataConEntry dcon
entry = funcName `dot` "entry"
exact = funcName `dot` "exact"
this = entry `dot` "this"
......@@ -116,29 +124,183 @@ codegenTop' name rhs = case rhs of
Lit.MachStr str -> do
strName <- string name str
return $ TaggedPointer strName 0
Lit.MachNullAddr -> error "machNullAddr" -- NullCtor
Lit.MachLabel {} -> error "machLabel" -- ExternCtor "label"
Lit.MachNullAddr -> do
traceShowM ("MachNullAddr inside", closureNameOf name)
return NullPointer
Lit.MachLabel {} -> do
-- TODO: replace with something else
traceShowM ("MachLabel inside", closureNameOf name)
return NullPointer
StgVarArg argId -> return $ TaggedPointer (closureNameOf argId) 0
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body -> do
-- traceShowM ("stg closure", closureNameOf name)
closure name [] $ closureBody name vars body
-- | Generate the closure code corresponding to an 'StgExpr'.
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
[]
(Return [paramName])
funcdef funcName (Version "1") muClosureFunctionSig $
basicBlock entry [(this, muClosureRef)] $ do
withBindings entry this vars $ do
sequel <- lift $ placeholderBlocks (fromString "@zzz")-- expression name body
traceShowM ("gonna branch to ", sequel)
boundNames <- sortedIDNames
return $ Branch1 $ DestinationClause sequel boundNames
return funcName
where
entry = funcName `dot` "entry"
this = funcName `dot` "entry.this"
funcName = entryNameOf name
bbName = funcName `dot` "entry"
paramName = bbName `dot` "param"
retVal = bbName `dot` "ret"
-- | Bind some arguments from a closure to actual Mu values.
--
-- For this to work, there need to be at least as many values in the closure as
-- there are arguments that need to be bound.
withBindings :: BasicBlockName -- ^ Name of the current 'BasicBlock'
-> VarName -- ^ Variable pointing to the closure with the
-- arguments to bind
-> [GHC.Id] -- ^ Arguments to bind
-> ExpWriter a
-> ExpWriter a
withBindings name this vars code = do
thisRef <- assign $ GetVarPartIRef False muClosure this
one <- upConstant 1
let bindArg :: (VarName, CapturedIDs) -> GHC.Id -> ExpWriter (VarName, CapturedIDs)
bindArg (ref, cIDs) var = do
val <- assign $ Load False Nothing haskellData thisRef Nothing
ref' <- assign $ ShiftIRef False muClosure i64 ref one
return (ref', M.insert var val cIDs)
bindings <- ask
(_, cIDs') <- foldM bindArg (thisRef, bindings) vars
code `capturing` cIDs'
-- | Emit a basic block that returns a new closure.
mkClosure :: FunctionName -- ^ The enclosing function for this block (for
-- naming purposes)
-> FunctionName -- ^ The function to be called
-> [StgArg] -- ^ List of arguments
-> Blocks BasicBlockName
mkClosure outerFun target args = do
bb <- basicBlock entry [] $ mkClosure' targetName args
emitBB bb
return entry
where
entry = outerFun `dot` "mkClosure"
this = entry `dot` "this"
targetName = VarName $ toName target
-- | Emit a basic block that returns a new closure. Also generate code to
-- extract the entry function from any 'GHC.Id' first.
mkClosureIndirect :: FunctionName
-> GHC.Id
-> [StgArg]
-> Blocks BasicBlockName
mkClosureIndirect outerFun targetID args = do
bb <- basicBlock entry [] $ do
targetName <- lookupID targetID
mkClosure' targetName args
emitBB bb
return entry
where
entry = outerFun `dot` "mkClosure"
this = entry `dot` "this"
-- | Create and populate a Mu Closure
mkClosure' :: VarName -- ^ Variable holding the name of the closure
-> [StgArg] -- ^ List of arguments
-> ExpWriter Expression
mkClosure' target args = do
-- create the closure
closLen <- upConstant (length args)
clos <- assign $ NewHybrid muClosure i64 closLen Nothing
-- populate the fields
closFunctionField <- assign $ GetFieldIRef False muClosure (fromEnum EntryField) clos
emit $ Store False Nothing muClosureFunction closFunctionField target Nothing
-- TODO: figure out the arity of this closure
-- TODO: populate the arguments
return $ Return [clos]
instance Show Var.Var where
show = show . entryNameOf
expression :: GHC.Id -- ^ The ID of the enclosing closure this belongs to
-> StgExpr -- ^ STG Expression to translate
-> Blocks BasicBlockName -- ^ The name of the block that starts
-- this expression
expression name topExpr = do
bindings <- ask
traceShowM ("inside expression for: ", entryNameOf name)
traceShowM ("bindings are: ", bindings)
case topExpr of
StgApp fun args
| isInternal fun -> traceShow ("internal StgApp", entryNameOf fun) $ do
mkClosureIndirect (entryNameOf name) fun args
| otherwise -> mkClosure (entryNameOf name) (entryNameOf fun) args
StgConApp con args
| isUnboxedTupleCon con -> traceShow ("unboxed StgConApp", dataConEntry con)
$ mkClosure (entryNameOf name) (dataConEntry con) args
-- error . show $ ("StgConApp unboxedtuple not implemented", closureNameOf name)
| otherwise -> traceShow ("StgConApp", dataConEntry con) $ mkClosure (entryNameOf name) (dataConEntry con) args
StgOpApp {} -> placeholderBlocks (entryNameOf name)
StgCase {} ->
placeholderBlocks (entryNameOf name)
StgLet binds expr -> do
-- traceShowM (showBind binds)
placeholderBlocks (entryNameOf name)
-- expression expr
where
showBind (StgNonRec bindId _) = show $ closureNameOf bindId
showBind (StgRec binds) = show $ fmap (closureNameOf . fst) binds
StgLetNoEscape _live_lhs _live_rhs binds expr -> expression name (StgLet binds expr)
StgLam {} -> error "panic: found a StgLam expression"
StgLit {} -> error "StgLit not implemented"
StgTick {} -> error "StgTick not implemented"
where
entry = entryNameOf name
-- Note [Applications]
-- ~~~~~~~~~~~~~~~~~~~
--
-- StgApp bindings can be used for many different things; for example the `id`
-- function translates to an StgApp of the first argument (whatever it is).
-- This might be a function, it might be a data value, it could be anything.
placeholderBlocks :: FunctionName -> Blocks BasicBlockName
placeholderBlocks n = do
emitBB $ BasicBlock bbName [(param, muClosureRef)] Nothing
[]
(Return [param])
return bbName
where