Commit 6cbb398d authored by nathyong's avatar nathyong

Begin migration to Mu API backed code generation

parent acc2529e
......@@ -15,19 +15,28 @@ cabal-version: >=1.10
library
hs-source-dirs: src
other-extensions:
TemplateHaskell,
GeneralizedNewtypeDeriving
ghc-options: -Wall
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
, Compiler.Mu.Monad
, Compiler.Mu.Types
, Compiler.Mu.FromSTG
, Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5
, mtl
, ansi-wl-pprint
, bytestring
, containers
, ghc
, ghc-simple
, containers
, bytestring
, ansi-wl-pprint
, hoopl
, hs-mu
, microlens-platform
, mtl
, mu
, mu-pure
, transformers
default-language: Haskell2010
executable anuhc-exe
......
......@@ -13,14 +13,11 @@ module Compiler.Mu
import TyCon (TyCon)
import StgSyn (StgBinding)
import Outputable (showSDocForUser, ppr, alwaysQualify)
import Language.Haskell.GHC.Simple (ModMetadata (..), ms_hspp_opts)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG
import Mu.PrettyPrint
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO String
compileMu metadata stg =
return . (showSDocForUser dflags qualifier) . ppr $ stgToMu metadata stg
where
dflags = ms_hspp_opts (mmSummary metadata)
qualifier = alwaysQualify
compileMu metadata stg = return . pp $ stgToMu metadata stg
-- |
-- Module : Compiler.Mu.CodeGen
-- Copyright : nathyong 2016
-- License : BSD3
--
-- Maintainer : nathyong@gmail.com
-- Stability : experimental
-- Portability : unknown
--
-- Utility functions for Haskell code generation via Mu.
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Compiler.Mu.CodeGen (
-- * Code generation
emitClosure
-- * Utility functions
, stringify
) where
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad.State (State, MonadState)
import Var (varName)
import Name (nameOccName, occNameFS)
import qualified GHC as GHC
import Compiler.Mu.Monad
import Mu.PrettyPrint (PrettyPrint (..))
import Mu.Syntax
-------------------------------------------------- * Code generation
emitClosure :: GHC.Id -> String -> Int -> Mu String -> Mu ()
emitClosure name typeName nargs code = do
_func_name <- code
return ()
-------------------------------------------------- * Utility functions
stringify :: GHC.Id -> String
stringify = show . occNameFS . nameOccName . varName
......@@ -11,10 +11,12 @@
-- Code generation facilities for the Mu Micro Virtual Machine
--
module Compiler.Mu.FromSTG
( stgToMu
(
-- * Main entry points
stgToMu
) where
-- * Main entry points
import Data.Char (ord)
import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
......@@ -30,38 +32,62 @@ import TyCon (TyCon)
import StgSyn
(StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg,
GenStgArg(..), StgExpr, GenStgExpr(..), UpdateFlag(..))
import qualified GHC as GHC
import Id (Id)
import Compiler.Mu.CodeGen
import Compiler.Mu.Monad
import Mu.Syntax
import Mu.Builder
import Compiler.Mu.Types
import qualified Mu.Syntax as Mu
-- | Compile the information inside an STG module into a MuBundle.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Mu.Program
stgToMu modData (tyCons, bindings) = runMu emptyBundle $ do mapM_ codegenTop bindings
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Either MuException Program
stgToMu modData (tyCons, bindings) =
buildMu $ do
loadTypes
mapM_ codegenTop bindings
loadTypes :: Mu ()
loadTypes = do
_ <- putTypedef "i3" $ MuInt 3
i64 <- putTypedef "i64" $ MuInt 64
_mu_tagref <- putTypedef "_mu_tagref" TagRef64
_ <- putTypedef "_mu_hybrid" $ Hybrid [i64, _mu_tagref] i64
return ()
-- mapM_ codegenTopTypes tyCons
codegenTop :: StgBinding -> Mu ()
codegenTop binding = undefined
-- case binding of
-- StgNonRec bindId rhs -> cgTop (nameOf bindId) rhs
-- StgRec pairs -> unzipWith (cgTop . nameOf) pairs
-- where unzipWith f = mapM_ (uncurry f)
codegenTop binding =
case binding of
StgNonRec bindId rhs -> cgTop bindId rhs
StgRec pairs -> unzipWith cgTop pairs
where unzipWith f = mapM_ (uncurry f)
-------------------------------------------------- Utilities
cgTop :: GHC.Id -> StgRhs -> Mu ()
cgTop name rhs =
case rhs of
-- make the top-level constructor, need to output code for it?
-- emitTop name (TypeTop name (length args) con)
StgRhsCon _cc con args -> do
i64 <- getTypedef "i64"
_ <- putConstant (stringify name) i64 "some_value"
return ()
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
emitClosure name "some_type_name" (length vars) $
cgClosureBody vars body
cgClosureBody :: [GHC.Id] -> StgExpr -> Mu String
cgClosureBody vars body = do
return "FunctionName"
-- cgTop :: Name -> StgRhs -> Mu ()
-- cgTop name rhs =
-- case rhs of
-- StgRhsCon _cc con args
-- -- make the top-level constructor, need to output code for it?
-- -- emitTop name (TypeTop name (length args) con)
-- -> return ()
-- StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
-- emitClosureTop name (Name "some_type_name") (length vars) $
-- cgClosureBody (fmap nameOf vars) body
--
--
-- -- | Convert an StgBinding to Mu Code.
-- cgBindings :: StgBinding -> MuCode ()
-- cgBindings stgBinding =
......
-- |
-- Module : Compiler.Mu.Kappa
-- Copyright : Nathan Yong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- Stability : experimental
-- Portability : unknown
--
-- Kappa is a letter that comes before Mu, and is not Lambda. It is
-- a transformation target that can be converted to Mu reasonably easily,
-- designed for an easy mapping from STG.
--
-- Within the Kappa translation process, it is assumed that all names are
-- globally unique (!).
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Compiler.Mu.Kappa
-- * Builder interface
-- $builderInterface
( Kappa
, runKappa
, emitTop
, emitClosureTop
, ProcM
-- * Data types
, Bundle(..)
, addTop
, emptyBundle
, Top(..)
, Procedure(..)
, Expression(..)
, Const(..)
, Name(..)
, nameOf
, Named(..)
-- * Classes
, HasType(..)
, Normalisable(..)
, Allocatable(..)
) where
import Control.Monad.State
(State, MonadState, execState, modify, runState, get, put)
import Data.ByteString (ByteString)
import Data.Char (ord)
import Data.Map (Map)
import Data.Maybe (fromJust)
import Prelude hiding ((<$>))
import qualified Data.Map as M
import DataCon (DataCon)
import Name (nameOccName, getName)
import OccName (occNameFS)
import Outputable
(Outputable(..), SDoc, ($+$), (<+>), (<>), brackets, hsep, empty,
hang, blankLine, text, parens, vcat, nest, int, double, pprHsBytes)
import Unique (getUnique)
import qualified Language.Haskell.GHC.Simple as GHC
-------------------------------------------------- * Builder interface
-- $builderInterface
-- The 'Kappa' monad is used for building the high-level bundle itself, while
-- the 'ProcM' monad is used for generating individual procedures inside each
-- bundle.
-- | A monadic environment for building Kappa types.
--
newtype Kappa a = Kappa
{ unKappa :: State Bundle a
} deriving (Functor, Applicative, Monad, MonadState Bundle)
-- | Extract the 'Bundle' from a Kappa monad.
runKappa :: Bundle -> Kappa a -> Bundle
runKappa = flip (execState . unKappa)
-- | Emit a top-level binding into a Kappa monadic environment.
emitTop :: Name -> Top -> Kappa ()
emitTop name top = modify (addTop name top)
-- | Emit a top-level closure into a Kappa monadic environment
emitClosureTop :: Name -> Name -> Int -> ProcM Procedure -> Kappa ()
emitClosureTop topName typeName arity procM = emitTop topName closure
where
closure =
ClosureTop
{ ktName = topName
, ktType = typeName
, ktArity = arity
, ktMainProc = mainProc
, ktOtherProcs = otherProcs
}
(mainProc, otherProcs) = runProcM procM
-- | An environment for building procedures.
--
newtype ProcM a = ProcM
{ unProcM :: State ProcState a
} deriving (Functor, Applicative, Monad, MonadState ProcState)
-- | Internal state for the 'ProcM' monad
data ProcState = ProcState
{ procedures :: [Procedure]
, upvalues :: [(Name, Const)]
}
initialProcState :: ProcState
initialProcState = ProcState [] []
-- | Extract procedures (with explicit entry procedure) from a 'ProcM'.
runProcM :: ProcM Procedure -> (Procedure, [Procedure])
runProcM = extractProcedures . flip runState initialProcState . unProcM
where
extractProcedures (entry, state) = (entry, procedures state)
-------------------------------------------------- * Data types
-- | A collection of Kappa top-level declarations.
--
data Bundle =
Bundle (Map Name Top)
instance Outputable Bundle where
ppr (Bundle kvs) = M.foldrWithKey go empty kvs
where
go k v doc = doc $+$ (hang (ppr k <> ":") 4 (ppr v)) $+$ blankLine
-- | Add a top-level binding into a Kappa bundle.
addTop :: Name -> Top -> Bundle -> Bundle
addTop name top (Bundle m) = Bundle $ M.insert name top m
-- | The empty Kappa bundle
emptyBundle :: Bundle
emptyBundle = Bundle M.empty
-- | Corresponds to top-level STG Binding, or top-level Cmm Closure.
--
data Top
-- | A top-level closure that yields a value. Examples include functions,
-- function applications, and complex data types.
= ClosureTop { ktName :: Name
, ktType :: Name
, ktArity :: !Int
, ktMainProc :: Procedure
, ktOtherProcs :: [Procedure]}
-- | A type constructor. May include references to other (GHC internals)
-- data constructors.
| TypeTop { ktName :: Name
, ktArity :: !Int
, ktDataCons :: DataCon}
instance Outputable Top where
ppr top =
case top of
ClosureTop {} ->
vcat
[ ppr (ktName top) <> "::" <> ppr (ktType top) <+>
parens ("arity:" <+> ppr (ktArity top))
, vcat $ fmap ppr ([ktMainProc top] ++ ktOtherProcs top)
]
TypeTop {} ->
vcat
[ ppr (ktName top) <+>
parens ("args:" <+> ppr (ktArity top))
, ppr $ ktDataCons top
]
-- | 'Procedure's are different from functions and closures by having the
-- following guarantees:
--
-- * They are strict in evaluation (although it may push a lazy closure)
-- * They are not recursive (although it may push a closure with
-- a reference to itself by name)
-- * They have a parameter list, which is always closures
--
data Procedure = Procedure
{ kpName :: Name
, kpArgs :: [Name]
, kpBody :: Expression
}
instance Outputable Procedure where
ppr proc = header <> "{" $+$ nest 4 (ppr (kpBody proc)) $+$ "}"
where
header = ppr (kpName proc) <> ppr (kpArgs proc)
-- | An 'Expression' is anything that can be reduced to a value.
--
data Expression
-- | Call a Haskell function, with arguments
= Call Name
[Name]
-- | Branch to different values, depending on the result of an expression.
| Switch Expression
Name
(Maybe Expression)
[(Const, Expression)]
-- | Emit code to push a closure to a particular value.
| MkClosure Name
Expression
-- | A literal value
| Literal Const
-- | A primitive operation. Will translate into a Mu primitive operation.
| PrimOps Name
Name
-- | Re-bind some fields in a closure to some values in a sub-expression
| Bind Name
!Int
Name
Expression
instance Outputable Expression where
ppr = pprExpression
-- | Kappa constants
--
data Const
= KInt !Int
| KDouble !Double
| TopClosure Name -- ^ Reference to a top-level closure by name
| KByteString ByteString
deriving (Eq)
instance Outputable Const where
ppr = pprConst
-- | Kappa names can be either local or global.
--
data Name =
Name String
deriving (Eq, Ord)
instance Outputable Name where
ppr (Name name) = "@" <> text name
nameOf :: GHC.Id -> Name
nameOf someId = Name (qualifier ++ idName ++ "_" ++ uniqueName)
where
qualifier = ""
-- pretty horrible. Eventually migrate away from strings?
idName = init . tail . show . occNameFS . nameOccName . getName $ someId
uniqueName = show . getUnique $ someId
-- | Things for which the result can be bound to a name.
--
data Named a
= Do a
| (:=) Name
a
instance Outputable a =>
Outputable (Named a) where
ppr (Do a) = ppr a
ppr (name := a) = ppr name <+> ":=" <+> ppr a
-------------------------------------------------- * Classes
-- | Things which have an observable type, perhaps within the context of
-- a Bundle (which you can lookup).
--
class HasType a
-- | Obtain the name of something, perhaps using the context of a particular
-- bundle.
where
typeOf :: a -> Bundle -> Name
instance HasType Const where
typeOf (KInt _) _ = Name "Mu.Int"
typeOf (KDouble _) _ = Name "Mu.Double"
typeOf (TopClosure n) (Bundle m) = ktName $ fromJust (M.lookup n m)
-- | Things which can be normalised to a Kappa literal.
--
class Normalisable a where
normalise :: a -> Const
instance Normalisable GHC.Literal where
normalise lit =
case lit of
GHC.MachInt i -> KInt (fromIntegral i)
GHC.MachInt64 i -> KInt (fromIntegral i)
GHC.MachWord i -> KInt (fromIntegral i)
GHC.MachWord64 i -> KInt (fromIntegral i)
GHC.MachFloat r -> KDouble (fromRational r)
GHC.MachDouble r -> KDouble (fromRational r)
GHC.LitInteger i _ -> KInt (fromIntegral i)
GHC.MachChar c -> KInt (fromIntegral (ord c))
GHC.MachStr str -> KByteString str
GHC.MachNullAddr -> error "normalise: null pointer not implemented"
GHC.MachLabel {} -> KByteString "label"
-- | Things which can be allocated at the top-level (for externalising
-- upvalues).
--
class (Monad m, Normalisable a) =>
Allocatable a m where
allocate :: a -> m Name
instance Allocatable GHC.Literal ProcM where
allocate lit = do
state <- get
name <- return $ Name "TODO: fix name"
let value = (name, normalise lit)
state' =
state
{ upvalues = value : (upvalues state)
}
put state'
return name
-------------------------------------------------- misc
pprExpression :: Expression -> SDoc
pprExpression expr =
case expr of
Call fn args -> "CALL" <+> ppr fn <+> hsep (fmap ppr args) <> ";"
Literal lit -> ppr lit
Switch scrutExpr scrutBind defaultExpr otherExprs ->
"SWITCH" <+>
brackets (ppr scrutBind <+> ":=" <+> ppr scrutExpr) <+>
"{" $+$
nest
4
(maybe empty printDefault defaultExpr $+$
vcat (fmap ppr otherExprs)) $+$
"}"
where printDefault e = parens $ "DEFAULT," <+> ppr e
MkClosure name body -> "CLOSURE" <+> ppr name <+> "..." <+> ppr body
Bind binder field bound subExpr ->
ppr binder <+>
":= GETFIELDIREF" <+>
ppr bound <+> parens (ppr field) $+$ "in" <+> ppr subExpr
pprConst :: Const -> SDoc
pprConst val =
case val of
KInt i -> int i
KDouble d -> double d
TopClosure name -> ppr name
KByteString bs -> pprHsBytes bs
-- |
-- Module : Compiler.Mu.Kappa.FromSTG
-- Copyright : nathyong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- Stability : experimental
-- Portability : unknown
--
-- Functions for translating STG code to Kappa form.
--
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Compiler.Mu.Kappa.FromSTG
( -- * Main entry points
stgToKappa
) where
import Data.Char (ord)
import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Literal (Literal (..))
import DataCon (DataCon , dataConWrapId)
import BasicTypes (RecFlag (..))
import Outputable (Outputable, pprTraceIt)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import GHC (ModSummary (..))
import DynFlags (DynFlags)
import TyCon (TyCon)
import StgSyn (StgBinding, GenStgBinding (..), StgRhs, GenStgRhs (..),
StgArg, GenStgArg (..),
StgAlt, GenStgAlt (..),
StgExpr, GenStgExpr (..),
UpdateFlag (..))
import qualified Language.Haskell.GHC.Simple as GHC
import Compiler.Mu.Kappa
-------------------------------------------------- * Main entry points
-- | The top-level transformation that transforms STG intermediate results to
-- Kappa representation.
--
stgToKappa :: ModMetadata -> ([TyCon], [StgBinding]) -> Bundle
stgToKappa modData (tyCons, bindings)
= runKappa emptyBundle $ do
mapM_ codegenTop bindings
-- mapM_ codegenTopTypes tyCons
-- codegenModInfo modData
-- | Transform a top-level STG binding to Kappa code
codegenTop :: StgBinding -> Kappa ()
codegenTop binding = case binding of
StgNonRec bindId rhs -> cgTop (nameOf bindId) rhs
StgRec pairs -> unzipWith (cgTop . nameOf) pairs
where
unzipWith f = mapM_ (uncurry f)
-- | Generate code for an STG top-level binding
cgTop :: Name -> StgRhs -> Kappa ()
cgTop name rhs = case rhs of
StgRhsCon _cc con args ->
emitTop name (TypeTop name (length args) con)
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
emitClosureTop name (Name "some_type_name") (length vars)
$ cgClosureBody (fmap nameOf vars) body
cgClosureBody :: [Name] -> StgExpr -> ProcM Procedure
cgClosureBody args body = cgExpr body >>= entryProc args
entryProc :: [Name] -> Expression -> ProcM Procedure
entryProc args code = return $ Procedure (Name "entry") args code
-- | Generate code for an StgExpr, the top-level of the STG syntax tree.
cgExpr :: StgExpr -> ProcM Expression
cgExpr expr = case expr of
StgCase scrut _live _live2 bndr _srt altType alts ->
cgCase scrut bndr altType alts
StgApp fn args -> cgApp fn args
StgLetNoEscape _live _live2 binds subExpr -> do
otherFunction <- cgExpr subExpr
return $ seq otherFunction $ Literal (KByteString "let nothing escape")
-- _pprError "cgExpr" binds
StgLet binds subExpr -> cgExpr subExpr
StgLit lit -> return $ Literal (normalise lit)
StgConApp {} -> return $ MkClosure (Name "ConApp") (Literal $ KInt 3)
StgOpApp {} -> _pprError "cgExpr.StgOpApp" expr
StgLam {} -> _pprError "cgExpr.StgLam" expr
StgTick {} -> _pprError "cgExpr.StgTick" expr
-- | Generate code for an `StgApp`, a function application.
cgApp :: GHC.Id -> [StgArg] -> ProcM Expression
cgApp fn args = do args' <- mapM argName args
return $ Call (nameOf fn) args'
where
-- maybe we need to generate upvalues for the literal arguments
argName arg = case arg of
StgVarArg argId -> return $ nameOf argId
StgLitArg lit -> allocate lit
-- | Generate code for an `StgCase`, a case/pattern matching expression.
cgCase :: StgExpr -> GHC.Id -> GHC.AltType -> [StgAlt] -> ProcM Expression
cgCase scrut bndr altType alts = do
scrutCode <- cgExpr scrut
(defaultCode, otherCodes) <- cgAlts (nameOf bndr) altType alts
return $ Switch scrutCode (nameOf bndr) defaultCode otherCodes
-- | Generate code for `StgAlt` branches (following the `StgCase` expression.
cgAlts :: Name -> GHC.AltType -> [StgAlt] -> ProcM (Maybe Expression, [(Const, Expression)])
cgAlts bndr altType alts = case (altType, alts) of
-- polymorphic data types come with only one RHS
(GHC.PolyAlt, [(_, _, _, rhs)]) -> do
altCode <- cgExpr rhs
return (Just altCode, [])
-- same with unboxed tuple alts
(GHC.UbxTupAlt _, [(_, _, _, rhs)]) -> do
altCode <- cgExpr rhs
return (Just altCode, [])
-- for an algebraic data type, generate the code for each of the alts and
-- then the jump code for the constructor, if it is tagged
--
-- TODO: the way this works is by jumping on the value (tag) of the data
-- constructor that is being used
(GHC.AlgAlt con, alts)
| GHC.isEnumerationTyCon con -> do
_pprError "Enumerated TyCon?" con
| otherwise -> do
altCodes <- mapM genAltCode alts
let familySize = GHC.tyConFamilySize con
let defaultCode = case altCodes of
(GHC.DEFAULT, rhs):_ -> Just rhs
_ -> Nothing
realAlts = [(KInt 3, altCode) {- TODO: fix -} | (GHC.DataAlt _, altCode) <- altCodes]
return (defaultCode, realAlts)
-- Primitive cases are easier, and they always have a default case too
(GHC.PrimAlt con, alts) -> do
altCodes <- mapM genAltCode alts
let defaultCode = case altCodes of
-- just to be careful
(GHC.DEFAULT, rhs):_ -> Just rhs
_ -> Nothing
realAlts = [ (normalise lit, altCode)
| (GHC.LitAlt lit, altCode) <- altCodes]
return (defaultCode, realAlts)
_ -> undefined
where
genAltCode :: StgAlt -> ProcM (GHC.AltCon, Expression)
genAltCode (con, bndrs, _, rhs) = seq (pprTraceIt "params" (con, bndrs)) $ do
expr <- cgExpr rhs >>= bindConArgs con bndrs
return (con, expr)
bindConArgs :: GHC.AltCon -> [GHC.Id] -> Expression -> ProcM Expression
bindConArgs con bndrs subExpr = return $ Bind (Name "binding") 13371337 bndr subExpr
_pprError :: Outputable a => String -> a -> b
_pprError msg val = seq (pprTraceIt msg val) undefined
-- |
-- Module : Compiler.Mu.Monad
-- Copyright : nathyong 2016
-- License : BSD3