Commit 38391e4e authored by nathyong's avatar nathyong

Add support for compiling multiple modules at once

parent 8aecd888
......@@ -13,14 +13,13 @@
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 Data.Map.Strict as M
import qualified Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple.Extra ()
......@@ -41,30 +40,28 @@ main = do
case b of
Success results _ _ -> do
putStrLn "Success!"
doResults $ foldr1 merge $ fmap modCompiledModule results
doResults $ mergeResults $ fmap modCompiledModule results
Failure _ _ -> putStrLn "Noooo"
where
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"]
, cfgGhcFlags = ["-v5", "-ddump-stg", "-ddump-to-file"]
}
doResults :: MuResult -> IO ()
doResults (bundle, topClosures, mainFunction) = do
doResults :: MuMergedResult -> IO ()
doResults (defns, topClosures, mainFunction) = do
mu <- newMu
ctx <- newContext mu
buildBundle ctx bundle
buildBundle ctx (Bundle defns')
mapM_ (populate ctx) topClosures
liveObjects <- mapM (getID ctx) $ fmap toName (unBundle bundle)
whitelist <- newArray $ toList liveObjects
let whitelistSz = fromIntegral . Seq.length $ liveObjects
liveObjects <- mapM (getID ctx) $ fmap toName defns'
whitelist <- newArray liveObjects
let whitelistSz = fromIntegral . length $ liveObjects
-- mainFunction <- getID ctx ("__haskell_main" :: FunctionName)
mainFunctionRef <- return nullPtr -- handleFromFunc ctx mainFunction
......@@ -73,6 +70,8 @@ doResults (bundle, topClosures, mainFunction) = do
mainFunctionRef nullPtr nullPtr -- main function
nullPtr nullPtr 0 -- symbols
nullPtr nullPtr 0 -- relocatables
where
defns' = M.elems defns
-- printResult :: CompResult String -> IO ()
-- printResult result = do putStrLn errors
......
......@@ -9,8 +9,10 @@
module Compiler.Mu
( compileMu
, populate
, MuResult
, MuMergedResult
, mergeResults
, populate
) where
import TyCon (TyCon)
......@@ -18,7 +20,7 @@ import StgSyn (StgBinding)
import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.CodeGen (MuResult, populate)
import Compiler.Mu.CodeGen (MuResult, MuMergedResult, mergeResults, populate)
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult
compileMu metadata stg = return $ stgToMu metadata stg
......@@ -23,6 +23,8 @@ module Compiler.Mu.CodeGen
, topLevels
, currentBlock
, MuResult
, MuMergedResult
, mergeResults
-- * Block building monad
, Blocks
, runBlocks
......@@ -57,16 +59,19 @@ module Compiler.Mu.CodeGen
, getClosureData
) where
import Control.Applicative ((<|>))
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.Foldable (toList, foldl')
import Data.List (genericLength)
import Data.Map.Strict (Map)
import Data.Monoid ((<>))
import Data.Sequence (Seq, (|>))
import Data.String (fromString)
import GHC.Generics (Generic)
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Foreign as F
import qualified Foreign.C as C
......@@ -94,6 +99,11 @@ data TopLevel = Closure GlobalCellName [UnboxedData] FunctionName
instance Binary TopLevel
instance HasName TopLevel where
toName tl = toName $ case tl of
Closure n _ _ -> n
ByteArray n _ -> n
data UnboxedData = UnboxedInt Integer
| UnboxedDouble Rational
| TaggedPointer GlobalCellName Int
......@@ -101,14 +111,27 @@ data UnboxedData = UnboxedInt Integer
instance Binary UnboxedData
type MuResult = (Seq Definition, Seq TopLevel, Maybe FunctionName)
type MuMergedResult = ( Map Name Definition
, Map Name TopLevel
, Maybe FunctionName)
mergeResults :: [MuResult] -> MuMergedResult
mergeResults = foldl' mergeResults' (M.empty, M.empty, Nothing)
where
mergeResults' :: MuMergedResult -> MuResult -> MuMergedResult
mergeResults' (defmap, topmap, fn) (defs, tops, fn') =
( foldl' insert defmap defs
, foldl' insert topmap tops
, fn <|> fn')
where
insert m n = M.insert (toName n) n m
-------------------------------------------------- * Mu Monad
newtype Mu a = Mu (State MuState a)
deriving (Functor, Applicative, Monad, MonadState MuState)
type MuResult = (Bundle, Seq TopLevel, Maybe FunctionName)
-- | Run a Mu computation from the empty state, storing the result.
runMu :: Mu a -> a
runMu (Mu code) = evalState code $ MuState 0 mempty mempty ()
......@@ -139,13 +162,13 @@ runBlocks (Blocks code) = do
-------------------------------------------------- * Code generation
-- | Extract the 'Bundle' and other useful things from the Mu monad.
-- | Extract the definitions and other useful things from the Mu monad.
bundleMu :: Mu () -> MuResult
bundleMu codegen = runMu $ do
codegen
defns <- gets _definitions
tops <- gets _topLevels
return (Bundle defns, tops, Nothing)
return (defns, tops, Nothing)
-- | Populate a Mu Closure, or other top-level data type, at build-time.
......
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