Commit acc2529e authored by nathyong's avatar nathyong

Testing!

parent f0cabf7d
......@@ -17,10 +17,7 @@ library
hs-source-dirs: src
ghc-options: -Wall
exposed-modules: Compiler.Mu
, Compiler.Mu.FromSTG
, Compiler.Mu.Types
, Compiler.Mu.PprMu
, Compiler.Mu.Kappa
, Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5
, mtl
......@@ -28,7 +25,9 @@ library
, ghc-simple
, containers
, bytestring
, ansi-wl-pprint
, hoopl
, hs-mu
default-language: Haskell2010
executable anuhc-exe
......
......@@ -12,19 +12,47 @@
module Main where
import qualified Data.ByteString.Char8 as BS8
import System.Environment (getArgs)
import Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple (CompResult (..), CompiledModule (..))
import qualified Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple.Extra ()
import Language.Haskell.GHC.Simple (CompResult (..), CompiledModule (..),
CompConfig (..))
import Compiler.Mu (compileMu)
main :: IO ()
main = do _ <- GHC.Simple.getDynFlagsForConfig GHC.Simple.defaultConfig
main = do _ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs
compiledModules <- GHC.Simple.compile compileMu inputFiles
case compiledModules of
Success results _ _ -> let printModule (CompiledModule str _ _) = putStrLn str
in mapM_ printModule results
Failure _ _ -> BS8.putStrLn "Noooo"
Failure _ _ -> putStrLn "Noooo"
where
config = GHC.Simple.disableCodeGen $ GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = False
, cfgStopPhases = GHC.Simple.ncgPhases
-- , cfgGhcFlags = ["-v5"]
}
-- printResult :: CompResult String -> IO ()
-- printResult result = do putStrLn errors
-- putStrLn warnings
-- putStrLn output
-- where
-- (output, errors, warnings) = showResults result
-- showResults :: CompResult a -> (String, String, String)
-- showResults results = case results of
-- Success res warns _flags -> (res, showWarns warns, "")
-- Failure warns errors -> ("", showWarns warns, showErrors errors)
-- where
-- showWarns :: [Warning] -> String
-- showWarns = concatMap showIt
-- where
-- showIt (Warning span msg) = show span ++ " " ++ msg
--
-- showErrors :: [Error] -> String
-- showErrors = concatMap showIt
-- where
......@@ -6,18 +6,21 @@
-- Stability : experimental
-- Portability : unknown
--
-- Code generation facilities for the Mu Micro Virtual Machine
--
module Compiler.Mu
( compileMu
) where
import Language.Haskell.GHC.Simple.Types
import TyCon (TyCon)
import StgSyn (StgBinding)
import Outputable (showSDocForUser, ppr, alwaysQualify)
import Language.Haskell.GHC.Simple (ModMetadata (..), ms_hspp_opts)
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.PprMu (showMu)
import Compiler.Mu.FromSTG
compileMu :: ModMetadata -> [StgBinding] -> IO String
compileMu metadata bindings = return . showMu $ stgToMu metadata bindings
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
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : MuCodeGen
-- Copyright : nathyong 2016
......@@ -9,27 +10,142 @@
--
-- Code generation facilities for the Mu Micro Virtual Machine
--
module Compiler.Mu.FromSTG
(
-- * Main entry points
stgToMu
) where
( stgToMu
) where
-- * Main entry points
import Data.Char (ord)
import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Language.Haskell.GHC.Simple (ModMetadata)
import StgSyn (StgBinding)
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(..), StgExpr, GenStgExpr(..), UpdateFlag(..))
import Id (Id)
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 -> [StgBinding] -> MuBundle
stgToMu modInfo stgBindings = undefined
-- 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)
--
--
-- 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 =
-- case stgBinding of
-- StgNonRec bindId rhs -> do
-- let (bindInfo, code) = muTopBinding NonRecursive bindId rhs
-- muBind bindInfo
-- code
-- StgRec pairs -> do
-- let (bindInfos, codes) =
-- unzip $ unzipWith (muTopBinding Recursive) pairs
-- mapM_ muBind bindInfos
-- sequence_ codes
-- where unzipWith f = map (uncurry f)
--
-- muTopBinding :: RecFlag -> Id -> StgRhs -> (MuBindInfo, MuCode ())
-- muTopBinding flag bndr rhs =
-- case rhs of
-- StgRhsCon _cc con arg -> cgTopRhsCon con bndr arg
-- StgRhsClosure _cc _bindinfo _nonfrees updateflag _srt vars body ->
-- cgTopRhsClosure flag bndr updateflag vars body
--
-- -- | Generate code for constructor applications at the top level.
-- cgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
-- cgTopRhsCon con bndr args = (info, code)
-- where
-- info = MuBindInfo bndr
-- get_lit arg =
-- seq (pprTraceIt "cgTopRhsCon" bndr) $
-- case arg of
-- StgVarArg var -> MuLabel var
-- StgLitArg lit ->
-- case cgLit lit of
-- MuLit l -> l
-- code = do
-- let payload = map get_lit args
-- emitGroup bndr [] (dataConWrapId con) payload
--
-- -- | Generate code for closures at the top level
-- cgTopRhsClosure :: RecFlag
-- -> Id
-- -> UpdateFlag
-- -> [Id]
-- -> StgExpr
-- -> (MuBindInfo, MuCode ())
-- cgTopRhsClosure flag bndr updateflag args body =
-- seq (pprTraceIt "cgTopRhsClosure" bndr) $ (bindInfo, genCode)
-- where
-- bindInfo = MuBindInfo bndr
-- genCode = forkMuClosure bndr (cgExpr body)
--
-- cgExpr :: StgExpr -> MuCode ()
-- cgExpr expr =
-- case expr of
-- StgLit lit -> void $ emitReturn (cgLit lit)
-- StgApp fn args -> error "StgApp not implemented"
-- _ -> error "not implemented"
--
-- emitReturn :: MuExpr -> MuCode Id
-- emitReturn results = emitBlock [] (MuReturn results)
--
-- -- | Convert literals into Mu literals.
-- cgLit :: Literal -> MuExpr
-- cgLit lit =
-- MuLit $
-- case lit of
-- MachInt i -> MuInt i 64
-- MachInt64 i -> MuInt i 64
-- MachWord i -> MuInt i 64
-- MachWord64 i -> MuInt i 64
-- MachFloat r -> MuFloat r
-- MachDouble r -> MuDouble r
-- LitInteger i _ -> MuInt i 64
-- MachChar c -> MuInt (fromIntegral (ord c)) 64
-- MachStr str -> MuByteString str
-- MachNullAddr -> _pprError "cgLit MachNullAddr" lit
-- MachLabel {} -> MuByteString "label"
_pprError
:: Outputable a
=> String -> a -> b
_pprError msg val = seq (pprTraceIt msg val) undefined
-- import StgSyn
--
--
-- import Util (unzipWith)
-- import BasicTypes (RecFlag (..))
-- import DynFlags
......@@ -37,8 +153,7 @@ stgToMu modInfo stgBindings = undefined
-- import OccName
-- import FastString
-- import Literal
-- import Outputable (pprTraceIt)
--
--
-- import CmmExpr
-- import HscTypes
-- import CostCentre
......@@ -49,18 +164,18 @@ stgToMu modInfo stgBindings = undefined
-- import TyCon
-- import Module
-- import PrelInfo (maybeIntLikeCon, maybeCharLikeCon)
--
--
-- import MuCodeGen.Types
--
--
-- import Data.Char (ord)
-- import Control.Monad (when, void, ap)
-- import Control.Monad.Trans.Writer.Strict
-- import Data.ByteString (ByteString)
-- import qualified Data.ByteString as BS
--
--
--
--
-- --------------------------------------------------------------------------------
--
--
-- muCodeGen :: HscEnv
-- -> Module
-- -> [TyCon]
......@@ -73,23 +188,23 @@ stgToMu modInfo stgBindings = undefined
-- where
-- output = muCodeGen' dflags this_mod type_constructors stg_binds
-- dflags = hsc_dflags hsc_env
--
--
--
--
-- muCodeGen' :: DynFlags -> Module -> [TyCon] -> [StgBinding] -> Writer MuBundle ()
-- muCodeGen' dflags _this_mod _type_constructors stg_binds = do
-- let cg :: MuCode () -> Writer MuBundle ()
-- cg muCode = tell $ evalMuCode (muCode >> extractBundle) (initialMuState dflags)
--
--
-- seq (pprTraceIt "MuCodeGen STG" stg_binds) (return ())
-- mapM_ (cg . muBindings) stg_binds
--
--
-- -- let do_tycon tycon = do
-- -- mapM_ (cg . genDataConstructor) (tyConDataCons tycon)
-- -- mapM_ do_tycon type_constructors
-- -- add information about the module
-- -- cg $ genModuleInfo this_mod
--
--
--
--
-- muBindings :: StgBinding -> MuCode ()
-- muBindings stg = case stg of
-- StgNonRec id rhs -> do
......@@ -100,15 +215,15 @@ stgToMu modInfo stgBindings = undefined
-- let (binders, codes) = unzip $ unzipWith (muTopBinding Recursive) pairs
-- mapM_ muBind binders
-- sequence_ codes
--
--
--
--
-- muTopBinding :: RecFlag -> Id -> StgRhs -> (MuBindInfo, MuCode ())
-- muTopBinding rec bndr rhs = case rhs of
-- StgRhsCon _cc con arg -> muCgTopRhsCon con bndr arg
-- StgRhsCon _cc con arg -> cgTopRhsCon con bndr arg
-- StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
-- (MuBindInfo bndr, return ())
--
--
--
--
-- -- genBinding :: RecFlag -> Id -> StgRhs -> MuCode ()
-- -- genBinding rec bndr rhs = do
-- -- muBind bndr
......@@ -118,32 +233,12 @@ stgToMu modInfo stgBindings = undefined
-- -- StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
-- -- genClosure rec updateflag vars body
-- -- muBlockToFunction bndr
--
--
-- muCgTopRhsCon :: DataCon -> Id -> [StgArg] -> (MuBindInfo, MuCode ())
-- muCgTopRhsCon con bndr args = (info, code)
-- where
-- info = MuBindInfo bndr
-- get_lit arg = seq (pprTraceIt "muCgTopRhsCon" bndr) $ case arg of
-- StgVarArg var -> MuLabel var
-- StgLitArg lit -> muCgLit lit
-- code = do let payload = map get_lit args
-- emitGroup bndr [] (dataConWrapId con) payload
--
--
-- muCgLit :: Literal -> MuLit
-- MachInt64 i -> MuInt i 64
-- MachWord i -> MuInt i 64
-- MachWord64 i -> MuInt i 64
-- MachFloat r -> MuFloat r
-- MachDouble r -> MuDouble r
-- -- MachStr s -> MuVector
-- _ -> seq (pprTraceIt "muCgLit" lit) $ error "Not implemented"
--
--
--
-- -- muCgTopRhsCon :: DataCon -> [StgArg] -> (MuBindInfo, MuCode ())
-- -- muCgTopRhsCon con args = case args of
--
--
--
--
-- -- cgTopRhsCon :: DataCon -> [StgArg] -> (MuBindInfo, MuCode ())
-- -- cgTopRhsCon con args = case args of
-- -- [] -> return () -- generate no code at all!
-- -- [StgLitArg (MachInt val)]
-- -- | maybeIntLikeCon con -> do
......@@ -156,15 +251,15 @@ stgToMu modInfo stgBindings = undefined
-- -- muEmitTop $ ConstructorHeader (dataConName con)
-- -- muEmitTop $ LiteralChar (fromIntegral (ord val))
-- -- _ -> void $ muEmitBlock $ toOL [MuStmt $ MuComment "StgRhsCon binding"]
--
--
--
--
-- -- -- | Generate the function body for a closure
-- -- genClosure :: RecFlag -> UpdateFlag -> [Id] -> StgExpr -> MuCode ()
-- -- genClosure _rec _updateflag vars body = do
-- -- -- need to emit a closure header somewhere
-- -- mucgExpr body
--
--
--
--
-- -- mucgExpr :: StgExpr -> MuCode ()
-- -- mucgExpr body = void $ case body of
-- -- StgApp fun args -> do
......@@ -181,22 +276,22 @@ stgToMu modInfo stgBindings = undefined
-- -- StgLet {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLet")]
-- -- StgLetNoEscape {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLetNoEscape")]
-- -- StgTick {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgTick")]
-- --
-- --
-- --
-- --
-- -- mucgCase :: StgExpr -> Id -> AltType -> [StgAlt] -> MuCode ()
-- -- mucgCase scrut bndr alt_type alts = do
-- -- muEmitBlock' [scrut] $ toOL [MuStmt (MuComment "StgCase")]
-- -- seq (pprTraceIt "some case" scrut) $ return ()
-- -- seq (pprTraceIt "bind it to" bndr) $ return ()
-- -- seq (pprTraceIt "some results" alts) $ return ()
-- --
-- --
-- -- -- force scrut
-- -- -- bind it to bndr
-- -- -- generate alts
-- --
-- --
-- -- -- scrutinise: evaluate @scrut@ and bind it to @bndr@
-- -- -- case-jump: branch on the value of the @bndr@
-- --
-- --
-- -- -- evaluate scrut and bind it sowhere
-- -- _ <- muEvalAndBind scrut bndr
-- -- mucgAlts bndr alt_type alts
......@@ -205,25 +300,25 @@ stgToMu modInfo stgBindings = undefined
-- -- muEvalAndBind scrut bndr = do
-- -- mucgExpr scrut
-- -- muEmitBlock $ toOL [MuStmt (MuComment "bind the thing somewhere")]
-- --
-- --
-- -- mucgAlts bndr alt_type alts = void $ case alt_type of
-- -- PolyAlt -> muEmitBlock $ toOL [MuStmt (MuComment "PolyAlt")]
-- -- UbxTupAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "UbxAlt")]
-- -- PrimAlt _ -> muEmitBlock $ toOL [MuStmt (MuComment "PrimAlt")]
-- -- AlgAlt tycon -> muEmitBlock $ toOL [MuStmt (MuComment "AlgAlt")]
-- --
-- --
-- --
-- --
-- -- -- Generate the entry code, info tables, and (for niladic constructor)
-- -- -- the static closure, for a constructor.
-- -- genDataConstructor :: DataCon -> MuCode ()
-- -- genDataConstructor _datacon = void $ muEmitBlock $ toOL [MuStmt (MuComment "Inside the data constructor now")]
-- --
-- --
-- --
-- --
-- -- genTypeConstructors :: TyCon -> MuCode ()
-- -- genTypeConstructors _tycon = do
-- -- void $ muEmitBlock $ toOL [MuStmt $ MuComment "Type constructor"]
-- --
-- --
-- --
-- --
-- -- genModuleInfo :: Module -> MuCode ()
-- -- genModuleInfo mod = do
-- -- muEmitTop (ModuleDecl name)
......
......@@ -6,130 +6,333 @@
-- Stability : experimental
-- Portability : unknown
--
-- Kappa is a letter that comes before Mu, and is not Lambda.
-- 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 (
-- * Data types
Bundle (..)
, Top (..)
, Procedure (..)
, Expression (..)
, Const (..)
, Name (..)
-- * Classes
, HasType (..)
) where
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)]
}
------------------------------------------------------------------- * Data types
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)
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]
}
-- | 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