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 =
......
This diff is collapsed.
-- |
-- 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
--
-- Maintainer : nathyong@gmail.com
-- Stability : experimental
-- Portability : unknown
--
-- Monad for interfacing with Mu
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Mu.Monad (
-- * Monad
Mu
, buildMu
, runMu
-- * Interface
, flatten
) where
import Control.Monad.Except (MonadError, ExceptT, runExceptT)
import Control.Monad.State (State, MonadState, evalState, get)
import Lens.Micro.Platform (assign, modifying, makeLenses)
import Mu.PrettyPrint (PrettyPrint (..))
import Mu.Syntax
import Mu.Builder hiding (flatten)
import qualified Mu.Builder
-------------------------------------------------- * Data structures
data MuState = MuState
{ _builderState :: BuilderState
, _currentBlock :: ()
}
makeLenses ''MuState
emptyMuState :: MuState
emptyMuState = MuState emptyBuilderState ()
-------------------------------------------------- * Monad
newtype Mu a = Mu (ExceptT MuException (State MuState) a)
deriving (Functor, Applicative, Monad, MonadState MuState, MonadError MuException)
instance PrettyPrint MuState where
ppFormat = ppFormat . flatten
instance MuBuilder Mu where
getBuilderState = get >>= return . _builderState
putBuilderState = assign builderState
getsBuilderState f = get >>= return . f . _builderState
modifyBuilderState = modifying builderState
buildMu :: Mu a -> Either MuException Program
buildMu mu = case runMu (mu >> get) of
Left x -> Left x
Right ms -> Right (flatten ms)
runMu :: Mu a -> Either MuException a
runMu (Mu code) = evalState (runExceptT code) emptyMuState
-------------------------------------------------- * Utility functions
-- | Transform a BuilderState into a Program
flatten :: MuState -> Program
flatten (MuState bs _) = Mu.Builder.flatten bs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Compiler.Mu.PprMu
( showMu
) where
import Data.Foldable (foldl')
import Compiler.Mu.Types
import Numeric (fromRat)
import OrdList
import Outputable
showMu :: MuBundle -> String
showMu = showSDocUnsafe . ppr
instance Outputable MuBundle where
ppr (MuBundle groups) = vcat2 groups
instance Outputable MuGroup where
ppr = pprMuGroup
instance Outputable MuClosure where
ppr = pprMuClosure
instance Outputable MuBlock where
ppr = pprMuBlock
instance Outputable (MuNode e x) where
ppr = pprMuNode
instance Outputable MuLit where
ppr = pprMuLit
pprMuGroup :: MuGroup -> SDoc
pprMuClosure :: MuClosure -> SDoc
pprMuBlock :: MuBlock -> SDoc
pprMuNode :: MuNode e x -> SDoc
pprMuLit :: MuLit -> SDoc
pprMuGroup group = hang' header 4 (decls $+$ codes) $+$ empty
where
header = ppr (mgLabel group) <> "_closure:"
decls = name $+$ args
name = "entry:" <+> ppr (entryFunction group)
args
| null (entryArgs group) = empty
| otherwise = hang' "args:" 4 $ vcat2 (entryArgs group)
codes
| null (mgClosures group) = empty
| otherwise = hang' "codes:" 4 $ vcat2 (mgClosures group)
pprMuClosure closure = hang' header 4 body
where
header = ppr (closureName closure) <> ":"
body = vcat2 (closureFunction closure)
pprMuBlock block = hang' header 4 body
where
header = ppr (blockId block) <> ":"
body = vcat2 (blockCode block) $+$ ppr (blockTerminator block)
pprMuNode node =
case node of
MuComment fs -> "//" <+> ppr fs
pprMuLit lit =
case lit of
MuInt i w ->
(if i < 0
then parens
else id) $
integer i <> dcolon <> "W" <> int w
MuFloat r -> double $ fromRat r
MuDouble r -> double $ fromRat r
MuLabel l -> ppr l
MuLabelOff l off -> ppr l <> pprOffset off
MuVector lits -> brackets (hsep . fmap ppr $ lits)
MuByteString bs -> pprHsBytes bs
pprOffset :: Int -> SDoc
pprOffset i
| i == 0 = empty
| i >= 0 = char '+' <> int i
| otherwise = char '-' <> int (-i)
-- | Convenience function as vcat for 'OrdList's
vcatOL :: Outputable a => OrdList a -> SDoc
vcatOL list
| isNilOL list = "[]"
| otherwise = showIt list
where
showIt = foldl' ($+$) empty . fromOL . fmap (("-" <+>) . ppr)
vcat2 :: Outputable a => [a] -> SDoc
vcat2 list
| null list = "[]"
| otherwise = showIt list
where
showIt = foldl' ($+$) empty . fmap (("-" <+>) . ppr)
hang' :: SDoc -> Int -> SDoc -> SDoc
hang' d1 n d2 = d1 $+$ nest n d2
This diff is collapsed.
This diff is collapsed.
-- Miscellaneous functions for transformation of Mu code.
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# http://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
# resolver:
# name: custom-snapshot
# location: "./custom-snapshot.yaml"
resolver: nightly-2016-08-05
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
# git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# extra-dep: true
# subdirs:
# - auto-update
# - wai
#
# A package marked 'extra-dep: true' will only be built if demanded by a
# non-dependency (i.e. a user package), and its test suites and benchmarks
# will not be run. This is useful for tweaking upstream packages.
packages:
- '.'
- '../hs-mu'
- '../haskell_libraries/mu'
- '../haskell_libraries/mu-pure'
# Dependency packages to be pulled from upstream that are not in the resolver
# (e.g., acme-missiles-0.3)
extra-deps: ["ghc-simple-0.4"]
extra-deps:
- 'ghc-simple-0.4'
- 'c-storable-deriving-0.1.3'
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.1"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
extra-lib-dirs:
- '/Users/nathan/projects/microvm/haskell_libraries/mu-impl-ref2/cbinding/'
# compiler-check: newer-minor
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