Commit 54c9a9b6 authored by nathyong's avatar nathyong

Initial commit (with old MuCodeGen source)

parents
dist
dist-*
cabal-dev
*.o
*.hi
*.chi
*.chs.h
*.dyn_o
*.dyn_hi
.hpc
.hsenv
.cabal-sandbox/
cabal.sandbox.config
*.prof
*.aux
*.hp
*.eventlog
.stack-work/
cabal.project.local
Copyright Author name here (c) 2016
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Author name here nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file
import Distribution.Simple
main = defaultMain
name: anuhc
version: 0.1.0.0
synopsis: ANU Haskell Compiler
description: Please see README.md
homepage: https://github.com/githubuser/anuhc#readme
license: BSD3
license-file: LICENSE
author: Author name here
maintainer: example@example.com
copyright: 2016 Author name here
category: Web
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Lib
build-depends: base >= 4.7 && < 5
default-language: Haskell2010
executable anuhc-exe
hs-source-dirs: app
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, ghc
, ghc-paths
, ghc-simple
, anuhc
default-language: Haskell2010
test-suite anuhc-test
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
build-depends: base
, ghc
, ghc-paths
, ghc-simple
, anuhc
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
source-repository head
type: git
location: https://github.com/githubuser/anuhc
module Main where
import Control.Monad.IO.Class (liftIO)
import Language.Haskell.GHC.Simple
targetFile = "B.hs"
main :: IO ()
main = do getDynFlagsForConfig defaultConfig
mod <- compile stgToMu [targetFile]
case mod of
Success results _ _ -> let printModule (CompiledModule txt _ _) = putStrLn txt
in mapM_ printModule results
Failure _ _ -> putStrLn "Noooo"
stgToMu :: ModMetadata -> [StgBinding] -> IO String
stgToMu _ _ = return "Hello, world!"
-- example = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
-- runGhc (Just libdir) $ do
-- dflags <- getSessionDynFlags
-- -- let dflags' = foldl xopt_set dflags
-- -- [Opt_Cpp, Opt_ImplicitPrelude, Opt_MagicHash]
-- setSessionDynFlags dflags
-- target <- guessTarget targetFile Nothing
-- setTargets [target]
-- load LoadAllTargets
-- modSum <- getModSummary $ mkModuleName "B"
-- p <- parseModule modSum
-- t <- typecheckModule p
-- d <- desugarModule t
-- l <- loadModule d
-- n <- getNamesInScope
-- let core_modguts = coreModule d
-- stg <- liftIO $ myCoreToStg dflags modSum core_modguts
-- return stg
-- --
-- -- g <- getModuleGraph
-- -- mapM showModule g
-- -- return $ (parsedSource d,"/n-----/n", typecheckedSource d)
--
--
-- myCoreToStg :: DynFlags -> ModSummary -> ModGuts -> IO ([StgBinding], CollectedCCs)
-- myCoreToStg dflags guts summary = do
-- env <- gg
-- liftIO $ do
-- stg_binds <- coreToStg dflags this_mod prepd_binds
-- return $ stg2stg dflags this_mod stg_binds
--
-- -- myCoreToStg :: DynFlags -> Module -> CoreProgram
-- -- -> IO ( [StgBinding] -- output program
-- -- , CollectedCCs) -- cost centre info (declared and used)
-- -- myCoreToStg dflags this_mod prepd_binds = do
-- -- stg_binds
-- -- <- {-# SCC "Core2Stg" #-}
-- -- coreToStg dflags this_mod prepd_binds
-- --
-- -- (stg_binds2, cost_centre_info)
-- -- <- {-# SCC "Stg2Stg" #-}
-- -- stg2stg dflags this_mod stg_binds
-- --
-- -- return (stg_binds2, cost_centre_info)
module Lib
( someFunc
) where
someFunc :: IO ()
someFunc = putStrLn "someFunc"
-- |
-- Module : MuCodeGen
-- Copyright : nathyong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- Stability : experimental
-- Portability : unknown
--
-- Code generation facilities for the Mu Micro Virtual Machine
--
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module MuCodeGen (
muCodeGen
) where
import StgSyn
import Util (unzipWith)
import BasicTypes (RecFlag (..))
import DynFlags
import OrdList
import OccName
import FastString
import Literal
import Outputable (pprTraceIt)
import CmmExpr
import HscTypes
import CostCentre
import Id
import IdInfo
import Type
import DataCon
import Name
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]
-> CollectedCCs
-> [StgBinding]
-> HpcInfo
-> IO MuBundle
muCodeGen hsc_env this_mod type_constructors _cost_centre_info stg_binds _hpc_info
= return $ execWriter output
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
let (binder, code) = muTopBinding NonRecursive id rhs
muBind binder
code
StgRec pairs -> do
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
StgRhsClosure _cc _bindinfo _nonfrees updateflag vars body ->
(MuBindInfo bndr, return ())
-- genBinding :: RecFlag -> Id -> StgRhs -> MuCode ()
-- genBinding rec bndr rhs = do
-- muBind bndr
-- case rhs of
-- StgRhsCon _cc con arg ->
-- genConstructor con arg
-- 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
muCgLit lit = 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
-- MachStr s -> MuVector
_ -> seq (pprTraceIt "muCgLit" lit) $ error "Not implemented"
-- muCgTopRhsCon :: DataCon -> [StgArg] -> (MuBindInfo, MuCode ())
-- muCgTopRhsCon con args = case args of
-- [] -> return () -- generate no code at all!
-- [StgLitArg (MachInt val)]
-- | maybeIntLikeCon con -> do
-- -- TODO: add more checks
-- muEmitTop $ ConstructorHeader (dataConName con)
-- muEmitTop $ LiteralInt (fromIntegral val)
-- [StgLitArg (MachChar val)]
-- | maybeCharLikeCon con -> do
-- -- TODO: add more checks
-- 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
-- _ <- muEmitBlock $ toOL [MuStmt (MuComment "StgApp")]
-- _ <- muEmitBlock $ toOL [MuStmt (MuFunCall fun args)]
-- return ""
-- StgLit {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLit")]
-- StgConApp con args -> muEmitBlock $ toOL [MuStmt (MuComment "StgConApp")]
-- StgOpApp {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgOpApp")]
-- StgLam {} -> muEmitBlock $ toOL [MuStmt (MuComment "StgLam")]
-- StgCase scrut bndr alt_type alts -> do
-- mucgCase scrut bndr alt_type alts
-- return ""
-- 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
-- return ()
-- where
-- 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)
-- where
-- name = moduleNameFS $ moduleName mod
-- |
-- Module : MuCode.CodeGenerator
-- Copyright : nathyong 2016
--
-- Maintainer : nathyong@gmail.com
-- Stability : experimental
-- Portability : unknown
--
-- Code generator monad from Mu Intermediate Representation.
--
-- Uses a "final tagless" DSL for code generation that maps to either a testing
-- semantics built on top of some pure monad, or the real code generation
-- semantics that is used for the compilation process.
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module MuCodeGen.CodeGenerator (
) where
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module MuCodeGen.PprMu () where
import Data.Foldable (foldl')
import Compiler.Hoopl
import DynFlags
import FastString
import Id
import MuCodeGen.Types
import Name
import Numeric ( fromRat )
import OrdList
import Outputable
import StgSyn
import UniqSupply
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 = hang' "declarations:" 4 $ (ppr $ entryFunction group) $+$ (vcat2 $ entryArgs group)
codes = 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) <> ":"
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 <> ppr_offset off
ppr_offset :: Int -> SDoc
ppr_offset 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
-- |
-- Module : MuCodeGen.Types
-- Copyright : nathyong 2016
-- License : BSD3
--
-- Maintainer : nathyong@gmail.com
-- Stability : experimental
-- Portability : unknown
--
-- Type structure for an intermediate representation of Mu Code
--
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module MuCodeGen.Types where
import Control.Monad (ap, liftM)
import Data.Map (Map)
import qualified Data.Map as M
import Data.ByteString (ByteString)
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
-- Mu data structures ------------------------------------------------------ {{{
-- | The Mu Program itself, which is expressed as a list of 'MuGroup's.
newtype MuBundle = MuBundle [MuGroup] deriving Monoid
-- | 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 #))
-- | State for the 'MuCode' monad.
data MuState = MuState
{ -- used for generating the current function
msBlocks :: [MuBlock]
, msBindings :: MuBindings
-- 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
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.