GitLab will continue to be upgraded from 11.4.5-ce.0 on November 25th 2019 at 4.00pm (AEDT) to 5.00pm (AEDT) due to Critical Security Patch Availability. During the update, GitLab and Mattermost services will not be available.

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
This diff is collapsed.
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
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Compiler.Mu.PprMu (showMu) where
module Compiler.Mu.PprMu
( showMu
) where
import Data.Foldable (foldl')
import Compiler.Mu.Types
import Numeric ( fromRat )
import Numeric (fromRat)
import OrdList
import Outputable
showMu :: MuBundle -> String
showMu = showSDocUnsafe . ppr
instance Outputable MuBundle where
ppr (MuBundle groups) = vcat2 groups
......@@ -38,40 +39,52 @@ 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 = hang' "declarations:" 4 $ ppr (entryFunction group) $+$ vcat2 (entryArgs group)
codes = hang' "codes:" 4 $ vcat2 (mgClosures group)
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 (blockName block) <> ":"
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 <> int w
MuFloat r -> double $ fromRat r
MuDouble r -> double $ fromRat r
MuLabel l -> ppr l
MuLabelOff l off -> ppr l <> pprOffset off
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
| 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
......@@ -80,7 +93,6 @@ vcatOL list
where
showIt = foldl' ($+$) empty . fromOL . fmap (("-" <+>) . ppr)
vcat2 :: Outputable a => [a] -> SDoc
vcat2 list
| null list = "[]"
......@@ -88,6 +100,5 @@ vcat2 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.
......@@ -9,223 +9,56 @@
--
-- Type structure for an intermediate representation of Mu Code
--
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Compiler.Mu.Types where
module Compiler.Mu.Types
( Mu(..)
) where
import Control.Monad.State (State(..))
import Control.Monad (ap, liftM)
import Data.Map (Map)
import qualified Data.Map as M
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Foldable (foldl')
import Data.Word
import Data.Int
import Compiler.Hoopl
import DynFlags
import FastString
import Id
import Name
import OrdList
import PprCmmExpr ()
import StgSyn
import UniqSupply
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)
-- Mu data structures ------------------------------------------------------ {{{
import Unique (getUnique)
import qualified Language.Haskell.GHC.Simple as GHC
-- | The Mu Program itself, which is expressed as a list of 'MuGroup's.
newtype MuBundle = MuBundle [MuGroup] deriving Monoid
import Mu.Builder
newtype Mu a =
Mu (State BuilderState a)
-- | The MuCode monad, for constructing a single MuGroup (analogous to
-- 'Cmm.CmmGroup'). This could be a function, or a literal.
newtype MuCode a = MuCode (MuState -> (# a, MuState #))
-------------------------------------------------- * Data types
data Name =
Name String
deriving (Show)
-- | State for the 'MuCode' monad.
data MuState = MuState
{ -- used for generating the current function
msBlocks :: [MuBlock]
, msBindings :: MuBindings
instance Outputable Name where
ppr (Name n) = text n
-- used for storing the rest of the module
, msGroups :: [MuGroup]
, msDynFlags :: DynFlags
}
instance Functor MuCode where
fmap f (MuCode code) = MuCode $ \s -> case code s of
(# a, s' #) -> (# f a, s' #)
instance Applicative MuCode where
pure a = MuCode $ \s -> (# a, s #)
(<*>) = ap
instance Monad MuCode where
return = pure
(MuCode code) >>= f = MuCode $ \s -> case code s of
(# a, s' #) -> case f a of
MuCode code' -> code' s'
instance HasDynFlags MuCode where
getDynFlags = getMuState >>= return . msDynFlags
type MuBindings = Map Id MuBindInfo
-- | Information of bindings
data MuBindInfo = MuBindInfo
{ bindingId :: Id
}
-- | A single MuGroup (analogous to 'Cmm.CmmGroup').
data MuGroup = MuGroup
{ mgLabel :: Id
, mgClosures :: [MuClosure]
, entryFunction :: Id
, entryArgs :: [MuLit]
}
-- | A closure of data and function
data MuClosure = MuClosure
{ closureName :: Id
, closureFunction :: [MuBlock]
}
-- | A Mu Basic Block
data MuBlock = MuBlock
{ blockArgs :: ()
, blockName :: Id
, blockCode :: [MuStmt]
, blockTerminator :: MuLastStmt
}
-- | Possible Mu node entries
data MuNode e x where
MuComment :: FastString -> MuNode O O
type MuStmt = MuNode O O
type MuLastStmt = MuNode O C
data MuLit = MuInt !Integer Int
| MuFloat !Rational
| MuDouble !Rational
| MuVector [MuLit]
| MuLabel Id
| MuLabelOff Id Int
--------------------------------------------------------------------------------
-- Functions
getMuState :: MuCode MuState
getMuState = MuCode $ \s -> (# s, s #)
putMuState :: MuState -> MuCode ()
putMuState s' = MuCode $ \_ -> (# (), s' #)
initialMuState :: DynFlags -> MuState
initialMuState dflags = MuState { msBlocks = []
, msBindings = M.empty
, msGroups = []
, msDynFlags = dflags
}
runMuCode :: MuCode a -> MuState -> (a, MuState)
runMuCode (MuCode code) state = case code state of
(# a, state' #) -> (a, state')
execMuCode :: MuCode a -> MuState -> MuState
execMuCode code state = snd $ runMuCode code state
evalMuCode :: MuCode a -> MuState -> a
evalMuCode code state = fst $ runMuCode code state
-- | Break out the blocks and bindings accumulated in a MuCode computation and
-- bind them into a group.
forkMuGroup :: Id -- ^ Id of group
-> Id -- ^ Id of entry function
-> MuCode a -- ^ Accumulated MuCode computation
-> MuCode ()
forkMuGroup groupId entry forkedCode = do
state <- getMuState
dflags <- getDynFlags
let inputState = initialMuState dflags
(_, forkedState) = runMuCode forkedCode inputState
-- putMuState $ state `addCodeFrom` forkedState
undefined
-- | Interact with the writer monad component of 'MuCode', adding an
-- instruction.
addBlock :: [MuStmt] -> MuLastStmt -> MuCode ()
addBlock = error "Not implemented"
addGroup :: MuGroup -> MuCode ()
addGroup group = do state <- getMuState
let groups' = msGroups state `mappend` [group]
putMuState $ state { msGroups = groups' }
emitGroup :: Id -> [MuClosure] -> Id -> [MuLit] -> MuCode ()
emitGroup groupId closures entry args
= addGroup $ MuGroup groupId closures entry args
-- | Add the binding information to the current group.
muBind :: MuBindInfo -> MuCode ()
muBind bindInfo = do
state <- getMuState
let bindings' = M.insert (bindingId bindInfo) bindInfo (msBindings state)
putMuState $ state { msBindings = bindings' }
-- | Extract the bundle out of the current MuState
extractBundle :: MuCode MuBundle
extractBundle = do state <- getMuState
return $ MuBundle (msGroups state)
-- -- | Get a "unique" ID from the MuCode monad.
-- getUniqueId :: MuCode Int
-- getUniqueId = do
-- state <- getMuState
-- let uniqueId = uniqueState state
-- putMuState $ state {uniqueState = uniqueId + 1}
-- return uniqueId
--
-- muEmitBlock :: OrdList MuStatement -> MuCode FastString
-- muEmitBlock' :: [Id] -> OrdList MuStatement -> MuCode FastString
-- muEmitTop :: MuDecl -> MuCode ()
--
-- -- | Generate code with separate loop and branch points.
-- --
-- -- Analogous to 'forkClosureBody'.
-- muForkClosureBody :: MuCode () -> MuCode ()
--
-- muEmitBlock = muEmitBlock' []
--
-- muEmitBlock' args stmts = do
-- blockId <- getUniqueId
-- state <- getMuState
-- let blockName = "block" `appendFS` (fsLit $ show blockId)
-- block = MuBlock blockName args stmts
-- codes' = muBlocks state `snocOL` block
-- putMuState $ state {muBlocks = codes'}
-- return blockName
--
--
-- muEmitTop decl = do state <- getMuState
-- let decls' = muTopLevelDecls state `snocOL` decl
-- putMuState $ state {muTopLevelDecls = decls'}
--
--
-- muForkClosureBody _code = undefined
-- | 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
-- Miscellaneous functions for transformation of Mu code.
......@@ -19,9 +19,22 @@ import DriverPipeline
import Language.Haskell.GHC.Simple.Types
instance Intermediate ([TyCon], [StgBinding]) where
prepare = toSimplifiedStgAndTyCons
instance Intermediate ([TyCon], [StgBinding], CollectedCCs) where
prepare = toSimplifiedStgPlus
toSimplifiedStgAndTyCons :: ModSummary -> CgGuts -> CompPipeline ([TyCon], [StgBinding])
toSimplifiedStgAndTyCons ms cgguts = do
env <- hsc_env `fmap` getPipeState
let dfs = hsc_dflags env
liftIO $ do
prog <- prepareCore env dfs ms cgguts
stg <- coreToStg dfs (ms_mod ms) prog
(binds, _) <- stg2stg dfs (ms_mod ms) stg
return (cg_tycons cgguts, binds)
-- | Compile a 'ModSummary' into a list of simplified 'StgBinding's.
-- See <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/StgSynType>
-- for more information about STG and how it relates to core and Haskell.
......
......@@ -36,7 +36,9 @@ resolver: nightly-2016-08-05
# 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'
# 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"]
......
module TestMain where
import Test.Tasty (defaultMain, testGroup)
main :: IO ()
main = putStrLn "Test suite not yet implemented"
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