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 ...@@ -15,19 +15,28 @@ cabal-version: >=1.10
library library
hs-source-dirs: src hs-source-dirs: src
other-extensions:
TemplateHaskell,
GeneralizedNewtypeDeriving
ghc-options: -Wall ghc-options: -Wall
exposed-modules: Compiler.Mu exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
, Compiler.Mu.Monad
, Compiler.Mu.Types , Compiler.Mu.Types
, Compiler.Mu.FromSTG
, Language.Haskell.GHC.Simple.Extra , Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, mtl , ansi-wl-pprint
, bytestring
, containers
, ghc , ghc
, ghc-simple , ghc-simple
, containers
, bytestring
, ansi-wl-pprint
, hoopl , hoopl
, hs-mu , microlens-platform
, mtl
, mu
, mu-pure
, transformers
default-language: Haskell2010 default-language: Haskell2010
executable anuhc-exe executable anuhc-exe
......
...@@ -13,14 +13,11 @@ module Compiler.Mu ...@@ -13,14 +13,11 @@ module Compiler.Mu
import TyCon (TyCon) import TyCon (TyCon)
import StgSyn (StgBinding) import StgSyn (StgBinding)
import Outputable (showSDocForUser, ppr, alwaysQualify) import Language.Haskell.GHC.Simple (ModMetadata (..))
import Language.Haskell.GHC.Simple (ModMetadata (..), ms_hspp_opts)
import Compiler.Mu.FromSTG import Compiler.Mu.FromSTG
import Mu.PrettyPrint
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO String compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO String
compileMu metadata stg = compileMu metadata stg = return . pp $ stgToMu metadata stg
return . (showSDocForUser dflags qualifier) . ppr $ stgToMu metadata stg
where
dflags = ms_hspp_opts (mmSummary metadata)
qualifier = alwaysQualify
-- |
-- 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 @@ ...@@ -11,10 +11,12 @@
-- Code generation facilities for the Mu Micro Virtual Machine -- Code generation facilities for the Mu Micro Virtual Machine
-- --
module Compiler.Mu.FromSTG module Compiler.Mu.FromSTG
( stgToMu (
-- * Main entry points
stgToMu
) where ) where
-- * Main entry points
import Data.Char (ord) import Data.Char (ord)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell) import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
...@@ -30,38 +32,62 @@ import TyCon (TyCon) ...@@ -30,38 +32,62 @@ import TyCon (TyCon)
import StgSyn import StgSyn
(StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg, (StgBinding, GenStgBinding(..), StgRhs, GenStgRhs(..), StgArg,
GenStgArg(..), StgExpr, GenStgExpr(..), UpdateFlag(..)) 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. -- | Compile the information inside an STG module into a MuBundle.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Mu.Program stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Either MuException Program
stgToMu modData (tyCons, bindings) = runMu emptyBundle $ do mapM_ codegenTop bindings 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 -- mapM_ codegenTopTypes tyCons
codegenTop :: StgBinding -> Mu () codegenTop :: StgBinding -> Mu ()
codegenTop binding = undefined codegenTop binding =
-- case binding of case binding of
-- StgNonRec bindId rhs -> cgTop (nameOf bindId) rhs StgNonRec bindId rhs -> cgTop bindId rhs
-- StgRec pairs -> unzipWith (cgTop . nameOf) pairs StgRec pairs -> unzipWith cgTop pairs
-- where unzipWith f = mapM_ (uncurry f) 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. -- -- | Convert an StgBinding to Mu Code.
-- cgBindings :: StgBinding -> MuCode () -- cgBindings :: StgBinding -> MuCode ()
-- cgBindings stgBinding = -- 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