Commit 33086195 authored by nathyong's avatar nathyong

Rewrite to use new Mu API interface

This even includes the C bindings, so the program actually runs stuff
now!
parent 6cbb398d
......@@ -21,9 +21,8 @@ library
ghc-options: -Wall
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
, Compiler.Mu.Monad
, Compiler.Mu.Types
, Compiler.Mu.FromSTG
, Compiler.Mu.Types
, Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5
, ansi-wl-pprint
......@@ -44,9 +43,11 @@ executable anuhc-exe
main-is: Main.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, text
, ghc-simple
, anuhc
, mu
, mu-pure
, ghc-simple
, text
default-language: Haskell2010
test-suite anuhc-test
......@@ -54,6 +55,8 @@ test-suite anuhc-test
hs-source-dirs: test
main-is: TestMain.hs
build-depends: base
, mu
, mu-pure
, tasty
, tasty-program
, ghc
......
......@@ -12,6 +12,10 @@
module Main where
import Data.List (genericLength)
import Foreign.C.String (newCString)
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Array (newArray)
import System.Environment (getArgs)
import qualified Language.Haskell.GHC.Simple as GHC.Simple
......@@ -20,14 +24,22 @@ import Language.Haskell.GHC.Simple (CompResult (..), CompiledModule (..),
CompConfig (..))
import Compiler.Mu (compileMu)
import Mu.API
import Mu.AST
import Mu.Execute
import Mu.Impl.RefImpl2
main :: IO ()
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
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"
where
config = GHC.Simple.disableCodeGen $ GHC.Simple.defaultConfig
......@@ -36,6 +48,27 @@ main = do _ <- GHC.Simple.getDynFlagsForConfig config
-- , cfgGhcFlags = ["-v5"]
}
doResults :: Bundle -> IO ()
doResults bundle = do
mu <- newMu
ctx <- newContext mu
buildBundle ctx bundle
liveObjects <- mapM (getID ctx) (liveObjectNames bundle)
whitelist <- newArray $ liveObjects
let whitelistSz = genericLength liveObjects
mainFunction <- getID ctx ("__haskell_main" :: FunctionName)
mainFunctionRef <- 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
......
......@@ -16,8 +16,7 @@ import StgSyn (StgBinding)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG
import Mu.AST (Bundle)
import Mu.PrettyPrint
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO String
compileMu metadata stg = return . pp $ stgToMu metadata stg
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO Bundle
compileMu metadata stg = return $ stgToMu metadata stg
......@@ -13,31 +13,44 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Compiler.Mu.CodeGen (
-- * Code generation
emitClosure
-- * Utility functions
, stringify
-- * Code generation
emitClosure
, typedef
, constant
-- * Utility functions
, stringify
) where
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad.State (State, MonadState)
import Lens.Micro.Platform ((%=))
import Var (varName)
import Name (nameOccName, occNameFS)
import qualified GHC as GHC
import Compiler.Mu.Monad
import Mu.PrettyPrint (PrettyPrint (..))
import Mu.Syntax
import Compiler.Mu.Types
import Mu.AST as Mu
-------------------------------------------------- * Code generation
emitClosure :: GHC.Id -> String -> Int -> Mu String -> Mu ()
emitClosure :: GHC.Id -> String -> Int -> Mu FunctionName -> Mu ()
emitClosure name typeName nargs code = do
_func_name <- code
return ()
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
-------------------------------------------------- * Utility functions
stringify :: GHC.Id -> String
......
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : MuCodeGen
-- Copyright : nathyong 2016
......@@ -10,6 +8,9 @@
--
-- Code generation facilities for the Mu Micro Virtual Machine
--
{-# LANGUAGE OverloadedStrings #-}
module Compiler.Mu.FromSTG
(
-- * Main entry points
......@@ -17,9 +18,10 @@ module Compiler.Mu.FromSTG
) where
import Data.Char (ord)
import Control.Monad (void)
import Control.Monad.Writer.Lazy (Writer, execWriter, tell)
import Data.Char (ord)
import Data.String (fromString)
import Literal (Literal(..))
import DataCon (DataCon, dataConWrapId)
......@@ -35,25 +37,23 @@ import StgSyn
import qualified GHC as GHC
import Compiler.Mu.CodeGen
import Compiler.Mu.Monad
import Mu.Syntax
import Mu.Builder
import Compiler.Mu.Types
import Mu.AST
-- | Compile the information inside an STG module into a MuBundle.
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Either MuException Program
stgToMu :: ModMetadata -> ([TyCon], [StgBinding]) -> Bundle
stgToMu modData (tyCons, bindings) =
buildMu $ do
bundleMu $ 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
_ <- typedef "_mu_tagref" TagRef64
_ <- typedef "i64" $ MuInt 64
_ <- typedef "_mu_hybrid" $ Hybrid ["i64", "_mu_tagref"] "i64"
return ()
......@@ -74,16 +74,15 @@ cgTop name rhs =
-- 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"
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
cgClosureBody :: [GHC.Id] -> StgExpr -> Mu String
cgClosureBody :: [GHC.Id] -> StgExpr -> Mu FunctionName
cgClosureBody vars body = do
return "FunctionName"
return $ "FunctionName"
......
-- |
-- 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
......@@ -7,58 +7,53 @@
-- Stability : experimental
-- Portability : unknown
--
-- Type structure for an intermediate representation of Mu Code
-- Monad for interfacing with Mu
--
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Compiler.Mu.Types
( Mu(..)
) where
module Compiler.Mu.Types (
-- * Data structures
Closure (..)
, definitions
, tops
, currentBlock
-- * Monad
, Mu
, bundleMu
, runMu
-- * Interface
) 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 Control.Monad.State (State, MonadState, evalState, get)
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)
import Lens.Micro.Platform (makeLenses)
import Unique (getUnique)
import qualified Language.Haskell.GHC.Simple as GHC
import qualified Mu.AST as Mu
import Mu.Builder
-------------------------------------------------- * Data structures
newtype Mu a =
Mu (State BuilderState a)
data Closure = Closure Mu.FunctionName
-------------------------------------------------- * Data types
data Name =
Name String
deriving (Show)
data MuState = MuState
{ _definitions :: [Mu.Definition]
, _tops :: [Closure]
, _currentBlock :: ()
}
instance Outputable Name where
ppr (Name n) = text n
makeLenses ''MuState
-- | Things for which the result can be bound to a name.
--
data Named a
= Do a
| (:=) Name
a
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)
instance Outputable a =>
Outputable (Named a) where
ppr (Do a) = ppr a
ppr (name := a) = ppr name <+> ":=" <+> ppr a
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