Commit 18834f48 authored by nathyong's avatar nathyong

Move code to new module structure

parent 54c9a9b6
...@@ -15,8 +15,17 @@ cabal-version: >=1.10 ...@@ -15,8 +15,17 @@ cabal-version: >=1.10
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: Lib exposed-modules: Compiler.Mu
, Compiler.Mu.FromSTG
, Compiler.Mu.Types
, Compiler.Mu.PprMu
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, text
, ghc
, ghc-simple
, containers
, bytestring
, hoopl
default-language: Haskell2010 default-language: Haskell2010
executable anuhc-exe executable anuhc-exe
...@@ -24,8 +33,7 @@ executable anuhc-exe ...@@ -24,8 +33,7 @@ executable anuhc-exe
main-is: Main.hs main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base build-depends: base
, ghc , text
, ghc-paths
, ghc-simple , ghc-simple
, anuhc , anuhc
default-language: Haskell2010 default-language: Haskell2010
......
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Main
-- Copyright : nathyong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- Stability : experimental
-- Portability : unknown
--
-- Main module for ANU Haskell Compiler.
--
module Main where module Main where
import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as BS8
import System.Environment (getArgs)
import Language.Haskell.GHC.Simple import Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple (CompResult (..), CompiledModule (..))
targetFile = "B.hs" import Compiler.Mu (compileMu)
main :: IO () main :: IO ()
main = do getDynFlagsForConfig defaultConfig main = do _ <- GHC.Simple.getDynFlagsForConfig GHC.Simple.defaultConfig
mod <- compile stgToMu [targetFile] inputFiles <- getArgs
case mod of compiledModules <- GHC.Simple.compile compileMu inputFiles
Success results _ _ -> let printModule (CompiledModule txt _ _) = putStrLn txt case compiledModules of
Success results _ _ -> let printModule (CompiledModule str _ _) = putStrLn str
in mapM_ printModule results in mapM_ printModule results
Failure _ _ -> putStrLn "Noooo" Failure _ _ -> BS8.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 : Compiler.Mu
-- Copyright : nathyong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- 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 StgSyn (StgBinding)
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.PprMu (showMu)
compileMu :: ModMetadata -> [StgBinding] -> IO String
compileMu metadata bindings = return . showMu $ stgToMu metadata bindings
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : MuCodeGen
-- Copyright : nathyong 2016
--
-- Maintainer : nathan.yong@anu.edu.au
-- Stability : experimental
-- Portability : unknown
--
-- Code generation facilities for the Mu Micro Virtual Machine
--
module Compiler.Mu.FromSTG
(
-- * Main entry points
stgToMu
) where
import Language.Haskell.GHC.Simple (ModMetadata)
import StgSyn (StgBinding)
import Compiler.Mu.Types
stgToMu :: ModMetadata -> [StgBinding] -> MuBundle
stgToMu modInfo stgBindings = undefined
--
--
-- 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 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
-- 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
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module MuCodeGen.PprMu () where module Compiler.Mu.PprMu (showMu) where
import Data.Foldable (foldl') import Data.Foldable (foldl')
import Compiler.Hoopl import Compiler.Mu.Types
import DynFlags
import FastString
import Id
import MuCodeGen.Types
import Name
import Numeric ( fromRat ) import Numeric ( fromRat )
import OrdList import OrdList
import Outputable import Outputable
import StgSyn
import UniqSupply
showMu :: MuBundle -> String
showMu = showSDocUnsafe . ppr
instance Outputable MuBundle where instance Outputable MuBundle where
...@@ -46,7 +42,7 @@ pprMuLit :: MuLit -> SDoc ...@@ -46,7 +42,7 @@ pprMuLit :: MuLit -> SDoc
pprMuGroup group = hang' header 4 (decls $+$ codes) $+$ empty pprMuGroup group = hang' header 4 (decls $+$ codes) $+$ empty
where where
header = ppr (mgLabel group) <> "_closure:" header = ppr (mgLabel group) <> "_closure:"
decls = hang' "declarations:" 4 $ (ppr $ entryFunction group) $+$ (vcat2 $ entryArgs group) decls = hang' "declarations:" 4 $ ppr (entryFunction group) $+$ vcat2 (entryArgs group)
codes = hang' "codes:" 4 $ vcat2 (mgClosures group) codes = hang' "codes:" 4 $ vcat2 (mgClosures group)
pprMuClosure closure = hang' header 4 body pprMuClosure closure = hang' header 4 body
...@@ -56,7 +52,7 @@ pprMuClosure closure = hang' header 4 body ...@@ -56,7 +52,7 @@ pprMuClosure closure = hang' header 4 body
pprMuBlock block = hang' header 4 body pprMuBlock block = hang' header 4 body
where where
header = ppr (blockName block) <> ":" header = ppr (blockName block) <> ":"
body = (vcat2 (blockCode block)) $+$ ppr (blockTerminator block) body = vcat2 (blockCode block) $+$ ppr (blockTerminator block)
pprMuNode node = case node of pprMuNode node = case node of
MuComment fs -> "//" <+> ppr fs MuComment fs -> "//" <+> ppr fs
...@@ -66,10 +62,10 @@ pprMuLit lit = case lit of ...@@ -66,10 +62,10 @@ pprMuLit lit = case lit of
MuFloat r -> double $ fromRat r MuFloat r -> double $ fromRat r
MuDouble r -> double $ fromRat r MuDouble r -> double $ fromRat r
MuLabel l -> ppr l MuLabel l -> ppr l
MuLabelOff l off -> ppr l <> ppr_offset off MuLabelOff l off -> ppr l <> pprOffset off
ppr_offset :: Int -> SDoc pprOffset :: Int -> SDoc
ppr_offset i pprOffset i
| i==0 = empty | i==0 = empty
| i>=0 = char '+' <> int i | i>=0 = char '+' <> int i
| otherwise = char '-' <> int (-i) | otherwise = char '-' <> int (-i)
......
-- | -- |
-- Module : MuCodeGen.Types -- Module : Compiler.Mu.Types
-- Copyright : nathyong 2016 -- Copyright : nathyong 2016
-- License : BSD3 -- License : BSD3
-- --
...@@ -12,9 +12,8 @@ ...@@ -12,9 +12,8 @@
{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module MuCodeGen.Types where module Compiler.Mu.Types where
import Control.Monad (ap, liftM) import Control.Monad (ap, liftM)
import Data.Map (Map) import Data.Map (Map)
......
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
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