Commit 37d3cf66 authored by nathyong's avatar nathyong

Begin support for language Primitive Operations

parent 38391e4e
...@@ -22,6 +22,7 @@ library ...@@ -22,6 +22,7 @@ library
exposed-modules: Compiler.Mu exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen , Compiler.Mu.CodeGen
, Compiler.Mu.FromSTG , Compiler.Mu.FromSTG
, Compiler.Mu.PrimOps
, Language.Haskell.GHC.Simple.Extra , Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, ansi-wl-pprint , ansi-wl-pprint
......
...@@ -18,6 +18,7 @@ import Foreign.C.String (newCString) ...@@ -18,6 +18,7 @@ import Foreign.C.String (newCString)
import Foreign.Ptr (nullPtr) import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Array (newArray) import Foreign.Marshal.Array (newArray)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
...@@ -36,19 +37,19 @@ main :: IO () ...@@ -36,19 +37,19 @@ main :: IO ()
main = do main = do
_ <- GHC.Simple.getDynFlagsForConfig config _ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs inputFiles <- getArgs
b <- GHC.Simple.compile compileMu inputFiles b <- GHC.Simple.compileWith config compileMu inputFiles
case b of case b of
Success results _ _ -> do Success results _ _ -> do
putStrLn "Success!" putStrLn "Success!"
doResults $ mergeResults $ fmap modCompiledModule results doResults $ mergeResults $ (loadPrim:) $ fmap modCompiledModule (results)
Failure _ _ -> putStrLn "Noooo" Failure _ _ -> exitFailure
where where
config = config =
GHC.Simple.disableCodeGen $ GHC.Simple.disableCodeGen $
GHC.Simple.defaultConfig GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = True { cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases , cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = ["-v5", "-ddump-stg", "-ddump-to-file"] , cfgGhcFlags = [{-"-v5",-} "-ddump-stg", "-ddump-to-file"]
} }
doResults :: MuMergedResult -> IO () doResults :: MuMergedResult -> IO ()
......
...@@ -13,6 +13,7 @@ module Compiler.Mu ...@@ -13,6 +13,7 @@ module Compiler.Mu
, MuMergedResult , MuMergedResult
, mergeResults , mergeResults
, populate , populate
, loadPrim
) where ) where
import TyCon (TyCon) import TyCon (TyCon)
...@@ -21,6 +22,7 @@ import Language.Haskell.GHC.Simple (ModMetadata (..)) ...@@ -21,6 +22,7 @@ import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG (stgToMu) import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.CodeGen (MuResult, MuMergedResult, mergeResults, populate) import Compiler.Mu.CodeGen (MuResult, MuMergedResult, mergeResults, populate)
import Compiler.Mu.PrimOps (loadPrim)
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult
compileMu metadata stg = return $ stgToMu metadata stg compileMu metadata stg = return $ stgToMu metadata stg
...@@ -37,9 +37,11 @@ module Compiler.Mu.CodeGen ...@@ -37,9 +37,11 @@ module Compiler.Mu.CodeGen
, constant , constant
, funcsig , funcsig
, funcdef , funcdef
, primfuncdef
, closure , closure
, string , string
-- * Utility functions -- * Naming interface
, dataConEntry
, closureNameOf , closureNameOf
, entryNameOf , entryNameOf
-- * Type names -- * Type names
...@@ -79,9 +81,8 @@ import Lens.Micro.Platform ((%=), makeLenses) ...@@ -79,9 +81,8 @@ import Lens.Micro.Platform ((%=), makeLenses)
import FastString (fsLit, zEncodeFS, zString) import FastString (fsLit, zEncodeFS, zString)
import qualified GHC import qualified GHC
import Name (nameStableString, isSystemName) import Name (NamedThing (..), nameStableString, isSystemName)
import Unique (getUnique) import Unique (Uniquable (..))
import Var (varName)
import Mu.API import Mu.API
import Mu.AST import Mu.AST
...@@ -284,23 +285,30 @@ funcdef n v sig body = do ...@@ -284,23 +285,30 @@ funcdef n v sig body = do
definitions %= (|> FunctionDefinition n v sig entry (toList bblocks)) definitions %= (|> FunctionDefinition n v sig entry (toList bblocks))
-------------------------------------------------- * Utility functions primfuncdef :: FunctionName -> Blocks BasicBlock -> Mu ()
primfuncdef n body = funcdef n (Version "1") muClosureFunctionSig body
stringify :: GHC.Id -> String
stringify n -------------------------------------------------- * Naming interface
| isSystemName name = '@':(stableName n <> "_" <> uniquePart n)
| otherwise = '@':(stableName n) stringify :: (Uniquable a, NamedThing a) => a -> String
stringify a
| isSystemName name = '@':(stableName name <> "_" <> uniquePart a)
| otherwise = '@':(stableName name)
where where
name = varName n name = getName a
stableName = zString . zEncodeFS . fsLit . nameStableString . varName stableName = zString . zEncodeFS . fsLit . nameStableString
uniquePart = show . getUnique uniquePart = show . getUnique
dataConEntry :: GHC.DataCon -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"
closureNameOf :: GHC.Id -> GlobalCellName closureNameOf :: GHC.Id -> GlobalCellName
closureNameOf n = fromString $ stringify n <> "_closure" closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
entryNameOf :: GHC.Id -> FunctionName entryNameOf :: GHC.Id -> FunctionName
entryNameOf n = fromString $ stringify n <> "_entry" entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
-------------------------------------------------- * Type names -------------------------------------------------- * Type names
......
...@@ -74,12 +74,8 @@ codegenTop' :: GHC.Id -> StgRhs -> Mu () ...@@ -74,12 +74,8 @@ codegenTop' :: GHC.Id -> StgRhs -> Mu ()
codegenTop' name rhs = case rhs of codegenTop' name rhs = case rhs of
StgRhsCon _cc con args -> do StgRhsCon _cc con args -> do
argLits <- mapM literal args argLits <- mapM literal args
closure name argLits $ return "@__placeholder" closure name argLits $ return (dataConEntry con)
where where
-- funcName = fromString $ stringify name <> "_static_entry"
-- bbName = funcName `subName` "entry"
-- param = bbName `subName` "param"
-- retVal = bbName `subName` "ret"
literal arg = case arg of literal arg = case arg of
StgLitArg lit -> case lit of StgLitArg lit -> case lit of
Lit.MachInt i -> return $ UnboxedInt i Lit.MachInt i -> return $ UnboxedInt i
......
-- |
-- Module : Compiler.Mu.PrimOps
-- Copyright : Author 2011-2012
-- License : BSD3
--
-- Maintainer : email@something.com
-- Stability : experimental
-- Portability : unknown
--
-- This module defines primitive Haskell operations in terms of Mu functions.
-- In the future we might define a slightly better way of doing this.
--
{-# LANGUAGE OverloadedStrings #-}
module Compiler.Mu.PrimOps
( loadPrim
) where
import Data.String (fromString)
import Compiler.Mu.CodeGen
import Mu.AST
loadPrim :: MuResult
loadPrim = bundleMu $ do
stub "@zdghczmprimzdGHCziTypeszdModule_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTyCon_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameS_static_entry"
stub "@zdghczmprimzdGHCziTypeszdTrNameD_static_entry"
stub :: FunctionName -> Mu ()
stub n = primfuncdef n (placeholderBlocks n)
placeholderBlocks :: FunctionName -> Blocks BasicBlock
placeholderBlocks n =
return $ BasicBlock bbName [(param, muClosureRef)] Nothing
[[retVal] := getClosureTag param]
(Return [retVal])
where
bbName = n `subName` "entry"
param = bbName `subName` "param"
retVal = bbName `subName` "ret"
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