Commit 37d3cf66 authored by nathyong's avatar nathyong

Begin support for language Primitive Operations

parent 38391e4e
......@@ -22,6 +22,7 @@ library
exposed-modules: Compiler.Mu
, Compiler.Mu.CodeGen
, Compiler.Mu.FromSTG
, Compiler.Mu.PrimOps
, Language.Haskell.GHC.Simple.Extra
build-depends: base >= 4.7 && < 5
, ansi-wl-pprint
......
......@@ -18,6 +18,7 @@ import Foreign.C.String (newCString)
import Foreign.Ptr (nullPtr)
import Foreign.Marshal.Array (newArray)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
......@@ -36,19 +37,19 @@ main :: IO ()
main = do
_ <- GHC.Simple.getDynFlagsForConfig config
inputFiles <- getArgs
b <- GHC.Simple.compile compileMu inputFiles
b <- GHC.Simple.compileWith config compileMu inputFiles
case b of
Success results _ _ -> do
putStrLn "Success!"
doResults $ mergeResults $ fmap modCompiledModule results
Failure _ _ -> putStrLn "Noooo"
doResults $ mergeResults $ (loadPrim:) $ fmap modCompiledModule (results)
Failure _ _ -> exitFailure
where
config =
GHC.Simple.disableCodeGen $
GHC.Simple.defaultConfig
{ cfgUseGhcErrorLogger = True
, cfgStopPhases = GHC.Simple.ncgPhases
, cfgGhcFlags = ["-v5", "-ddump-stg", "-ddump-to-file"]
, cfgGhcFlags = [{-"-v5",-} "-ddump-stg", "-ddump-to-file"]
}
doResults :: MuMergedResult -> IO ()
......
......@@ -13,6 +13,7 @@ module Compiler.Mu
, MuMergedResult
, mergeResults
, populate
, loadPrim
) where
import TyCon (TyCon)
......@@ -21,6 +22,7 @@ import Language.Haskell.GHC.Simple (ModMetadata (..))
import Compiler.Mu.FromSTG (stgToMu)
import Compiler.Mu.CodeGen (MuResult, MuMergedResult, mergeResults, populate)
import Compiler.Mu.PrimOps (loadPrim)
compileMu :: ModMetadata -> ([TyCon], [StgBinding]) -> IO MuResult
compileMu metadata stg = return $ stgToMu metadata stg
......@@ -37,9 +37,11 @@ module Compiler.Mu.CodeGen
, constant
, funcsig
, funcdef
, primfuncdef
, closure
, string
-- * Utility functions
-- * Naming interface
, dataConEntry
, closureNameOf
, entryNameOf
-- * Type names
......@@ -79,9 +81,8 @@ import Lens.Micro.Platform ((%=), makeLenses)
import FastString (fsLit, zEncodeFS, zString)
import qualified GHC
import Name (nameStableString, isSystemName)
import Unique (getUnique)
import Var (varName)
import Name (NamedThing (..), nameStableString, isSystemName)
import Unique (Uniquable (..))
import Mu.API
import Mu.AST
......@@ -284,23 +285,30 @@ funcdef n v sig body = do
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
| isSystemName name = '@':(stableName n <> "_" <> uniquePart n)
| otherwise = '@':(stableName n)
-------------------------------------------------- * Naming interface
stringify :: (Uniquable a, NamedThing a) => a -> String
stringify a
| isSystemName name = '@':(stableName name <> "_" <> uniquePart a)
| otherwise = '@':(stableName name)
where
name = varName n
stableName = zString . zEncodeFS . fsLit . nameStableString . varName
name = getName a
stableName = zString . zEncodeFS . fsLit . nameStableString
uniquePart = show . getUnique
dataConEntry :: GHC.DataCon -> FunctionName
dataConEntry n = FunctionName $ Name $ stringify n <> "_static_entry"
closureNameOf :: GHC.Id -> GlobalCellName
closureNameOf n = fromString $ stringify n <> "_closure"
closureNameOf n = GlobalCellName $ Name $ stringify n <> "_closure"
entryNameOf :: GHC.Id -> FunctionName
entryNameOf n = fromString $ stringify n <> "_entry"
entryNameOf n = FunctionName $ Name $ stringify n <> "_entry"
-------------------------------------------------- * Type names
......
......@@ -74,12 +74,8 @@ codegenTop' :: GHC.Id -> StgRhs -> Mu ()
codegenTop' name rhs = case rhs of
StgRhsCon _cc con args -> do
argLits <- mapM literal args
closure name argLits $ return "@__placeholder"
closure name argLits $ return (dataConEntry con)
where
-- funcName = fromString $ stringify name <> "_static_entry"
-- bbName = funcName `subName` "entry"
-- param = bbName `subName` "param"
-- retVal = bbName `subName` "ret"
literal arg = case arg of
StgLitArg lit -> case lit of
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