Commit a614454d authored by nathyong's avatar nathyong

Remove Types module for first iteration of codegen

parent 33086195
......@@ -22,10 +22,10 @@ library
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
, Compiler.Mu.FromSTG
, Compiler.Mu.Types
, Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5
, ansi-wl-pprint
, binary
, bytestring
, containers
, ghc
......@@ -46,6 +46,7 @@ executable anuhc-exe
, anuhc
, mu
, mu-pure
, containers
, ghc-simple
, text
default-language: Haskell2010
......
......@@ -12,63 +12,68 @@
module Main where
import Data.Monoid ((<>))
import Control.Applicative ((<|>))
import Data.Foldable (foldMap, toList, foldr1)
import Data.List (genericLength)
import Foreign.C.String (newCString)
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Array (newArray)
import System.Environment (getArgs)
import qualified Data.Sequence as Seq
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)
import Compiler.Mu
import Mu.API
import Mu.AST
import Mu.Execute
import Mu.Impl.RefImpl2
import Mu.Interface
main :: IO ()
main = do _ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs
bundle <- GHC.Simple.compile compileMu inputFiles
case bundle of
Success results _ _ -> do
putStrLn "Success!"
doResults bundle'
where
bundle' = merge $ map modCompiledModule results
merge = head
Failure _ _ -> putStrLn "Noooo"
main = do
_ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs
b <- GHC.Simple.compile compileMu inputFiles
case b of
Success results _ _ -> do
putStrLn "Success!"
doResults $ foldr1 merge $ fmap modCompiledModule results
Failure _ _ -> putStrLn "Noooo"
where
config = GHC.Simple.disableCodeGen $ GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = False
merge (b1, c1, e1) (b2, c2, e2) = (b1 <> b2, c1 <> c2, e1 <|> e2)
config =
GHC.Simple.disableCodeGen $
GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
-- , cfgGhcFlags = ["-v5"]
}
doResults :: Bundle -> IO ()
doResults bundle = do
doResults :: MuResult -> IO ()
doResults (bundle, topClosures, mainFunction) = do
mu <- newMu
ctx <- newContext mu
buildBundle ctx bundle
liveObjects <- mapM (getID ctx) (liveObjectNames bundle)
whitelist <- newArray $ liveObjects
let whitelistSz = genericLength liveObjects
mapM_ buildClosures topClosures
liveObjects <- mapM (getID ctx) $ fmap toName (unBundle bundle)
whitelist <- newArray $ toList liveObjects
let whitelistSz = fromIntegral . Seq.length $ liveObjects
mainFunction <- getID ctx ("__haskell_main" :: FunctionName)
mainFunctionRef <- handleFromFunc ctx mainFunction
-- mainFunction <- getID ctx ("__haskell_main" :: FunctionName)
mainFunctionRef <- return nullPtr -- handleFromFunc ctx mainFunction
newCString "output.mu" >>= makeBootImage ctx
whitelist whitelistSz -- object whitelist
mainFunctionRef nullPtr nullPtr -- main function
nullPtr nullPtr 0 -- symbols
nullPtr nullPtr 0 -- relocatables
liveObjectNames :: Bundle -> [Name]
liveObjectNames _bundle = []
-- printResult :: CompResult String -> IO ()
-- printResult result = do putStrLn errors
-- putStrLn warnings
......
......@@ -9,14 +9,16 @@
module Compiler.Mu
( compileMu
, buildClosures
, MuResult
) where
import TyCon (TyCon)
import StgSyn (StgBinding)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG
import Mu.AST (Bundle)
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.CodeGen (MuResult, buildClosures)
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO Bundle
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult
compileMu metadata stg = return $ stgToMu metadata stg
......@@ -11,47 +11,135 @@
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Mu.CodeGen (
module Compiler.Mu.CodeGen
( -- * Mu Monad
Mu
, runMu
, definitions
, tops
, currentBlock
, Closure (..)
, MuResult
-- * Block building monad
, Blocks
, runBlocks
-- * Code generation
emitClosure
, bundleMu
, buildClosures
, closure
-- * Mu interface
, typedef
, constant
, funcsig
, funcdef
-- * Utility functions
, stringify
) where
import Lens.Micro.Platform ((%=))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (State, StateT, MonadState, evalState, runStateT, gets)
import Data.Binary (Binary)
import Data.Foldable (toList)
import Data.Monoid ((<>))
import Data.Sequence (Seq, (|>))
import Data.String (fromString)
import GHC.Generics (Generic)
import Lens.Micro.Platform ((%=), makeLenses)
import Language.Haskell.GHC.Simple (ModMetadata(..))
import Var (varName)
import Name (nameOccName, occNameFS)
import qualified GHC as GHC
import Name (nameStableString)
import FastString (fsLit, zEncodeFS, zString)
import qualified GHC
import Mu.AST
-------------------------------------------------- * Mu Monad
newtype Mu a = Mu (State MuState a)
deriving (Functor, Applicative, Monad, MonadState MuState)
data Closure = Closure Name Int FunctionName
deriving (Generic)
instance Binary Closure
type MuResult = (Bundle, Seq Closure, Maybe FunctionName)
-- | Run a Mu computation from the empty state, storing the result.
runMu :: Mu a -> a
runMu (Mu code) = evalState code $ MuState mempty mempty ()
data MuState = MuState
{ _definitions :: Seq Definition
, _tops :: Seq Closure
, _currentBlock :: ()
}
makeLenses ''MuState
-------------------------------------------------- * Block building monad
data BlockState = BlockState { _blocks :: Seq BasicBlock }
import Compiler.Mu.Types
import Mu.AST as Mu
makeLenses ''BlockState
newtype Blocks a = Blocks (StateT BlockState Mu a)
deriving (Functor, Applicative, Monad, MonadState BlockState)
runBlocks :: Blocks a -> Mu (a, Seq BasicBlock)
runBlocks (Blocks code) = do
(a, bstate) <- runStateT code $ BlockState mempty
return (a, _blocks bstate)
-------------------------------------------------- * Code generation
emitClosure :: GHC.Id -> String -> Int -> Mu FunctionName -> Mu ()
emitClosure name typeName nargs code = do
_func_name <- code
return ()
-- | Extract the 'Bundle' from the Mu monad, accompanied with a list of live
-- objects in that bundle.
bundleMu :: Mu () -> MuResult
bundleMu codegen = runMu $ do
codegen
defns <- gets _definitions
closures <- gets _tops
return (Bundle defns, closures, Nothing)
buildClosures :: MonadIO m => Closure -> m ()
buildClosures cls = return ()
closure :: GHC.Id -> Int -> Mu FunctionName -> Mu ()
closure name nargs code = do
func_name <- code
tops %= (|> Closure (fromString $ stringify name) nargs func_name)
-------------------------------------------------- * Mu interface
typedef :: TypedefName -> Type -> Mu ()
typedef n ty = definitions %= (|> TypeDefinition n ty)
constant :: ConstantName -> TypedefName -> ConstConstructor -> Mu ()
constant n ty ctor = definitions %= (|> Constant n ty ctor)
funcsig :: SignatureName -> [TypedefName] -> [TypedefName] -> Mu ()
funcsig n argtys rettys = definitions %= (|> SignatureDefinition n argtys rettys)
typedef :: TypedefName -> Type -> Mu TypedefName
typedef n ty = do
definitions %= (`mappend` [TypeDefinition n ty])
return n
constant :: ConstantName
-> TypedefName
-> ConstConstructor
-> Mu ConstantName
constant n ty ctor = do
definitions %= (`mappend` [Constant n ty ctor])
return n
funcdef :: FunctionName -> Version -> SignatureName -> Blocks BasicBlock -> Mu ()
funcdef n v sig body = do
(entry, bblocks) <- runBlocks body
definitions %= (|> FunctionDefinition n v sig entry (toList bblocks))
-------------------------------------------------- * Utility functions
stringify :: GHC.Id -> String
stringify = show . occNameFS . nameOccName . varName
stringify = ('@':) . zString . zEncodeFS . fsLit . nameStableString . varName
......@@ -37,23 +37,22 @@ import StgSyn
import qualified GHC as GHC
import Compiler.Mu.CodeGen
import Compiler.Mu.Types
import Mu.AST
-- | Compile the information inside an STG module into a MuBundle.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Bundle
stgToMu modData (tyCons, bindings) =
bundleMu $ do
loadTypes
mapM_ codegenTop bindings
-- | Compile the information inside an STG module into a 'Bundle'.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> MuResult
stgToMu modData (tyCons, bindings) = bundleMu $ do
loadTypes
mapM_ codegenTop bindings
-- | Load a bunch of useful types into the current bundle.
loadTypes :: Mu ()
loadTypes = do
_ <- typedef "_mu_tagref" TagRef64
_ <- typedef "i64" $ MuInt 64
_ <- typedef "_mu_hybrid" $ Hybrid ["i64", "_mu_tagref"] "i64"
typedef "@_mu_tagref" TagRef64
typedef "@i64" $ MuInt 64
typedef "@_mu_hybrid" $ Hybrid ["@i64", "@_mu_tagref"] "@i64"
return ()
......@@ -61,24 +60,23 @@ loadTypes = do
codegenTop :: StgBinding -> Mu ()
codegenTop binding =
case binding of
StgNonRec bindId rhs -> cgTop bindId rhs
StgRec pairs -> unzipWith cgTop pairs
StgNonRec bindId rhs -> codegenTop' bindId rhs
StgRec pairs -> unzipWith codegenTop' 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
constant (fromString (stringify name)) "i64" (IntCtor 1337)
return ()
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
emitClosure name "some_type_name" (length vars) $
cgClosureBody vars body
codegenTop' :: GHC.Id -> StgRhs -> Mu ()
codegenTop' 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
constant (fromString (stringify name)) "@i64" (IntCtor 1337)
return ()
StgRhsClosure _cc _bindinfo _nonfrees _updateFlag _srt vars body ->
closure name (length vars) $ cgClosureBody vars body
cgClosureBody :: [GHC.Id] -> StgExpr -> Mu FunctionName
cgClosureBody vars body = do
......
-- |
-- Module : Compiler.Mu.Types
-- 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.Types (
-- * Data structures
Closure (..)
, definitions
, tops
, currentBlock
-- * Monad
, Mu
, bundleMu
, runMu
-- * Interface
) where
import Control.Monad.State (State, MonadState, evalState, get)
import Lens.Micro.Platform (makeLenses)
import qualified Mu.AST as Mu
-------------------------------------------------- * Data structures
data Closure = Closure Mu.FunctionName
data MuState = MuState
{ _definitions :: [Mu.Definition]
, _tops :: [Closure]
, _currentBlock :: ()
}
makeLenses ''MuState
emptyMuState :: MuState
emptyMuState = MuState [] [] ()
-------------------------------------------------- * Monad
newtype Mu a = Mu (State MuState a)
deriving (Functor, Applicative, Monad, MonadState MuState)
bundleMu :: Mu a -> Mu.Bundle
bundleMu mu = Mu.Bundle $ _definitions $ runMu (mu >> get)
runMu :: Mu a -> a
runMu (Mu code) = evalState code emptyMuState
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