{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToAsm.Wasm (ncgWasm) where
import Data.ByteString.Builder
import Data.ByteString.Lazy.Char8 (unpack)
import Data.Maybe
import Data.Semigroup
import GHC.Cmm
import GHC.Cmm.ContFlowOpt
import GHC.Cmm.GenericOpt
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Wasm.Asm
import GHC.CmmToAsm.Wasm.FromCmm
import GHC.CmmToAsm.Wasm.Types
import GHC.StgToCmm.CgUtils (CgStream)
import GHC.Data.Stream (StreamS (..), runStream, liftIO)
import GHC.Driver.DynFlags
import GHC.Platform
import GHC.Prelude
import GHC.Settings
import GHC.Types.Unique.DSM
import GHC.Unit
import GHC.Utils.Logger
import GHC.Utils.Outputable (text)
import System.IO
ncgWasm ::
NCGConfig ->
Logger ->
Platform ->
ToolSettings ->
ModLocation ->
Handle ->
CgStream RawCmmGroup a ->
UniqDSMT IO a
ncgWasm :: forall a.
NCGConfig
-> Logger
-> Platform
-> ToolSettings
-> ModLocation
-> Handle
-> CgStream RawCmmGroup a
-> UniqDSMT IO a
ncgWasm NCGConfig
ncg_config Logger
logger Platform
platform ToolSettings
ts ModLocation
loc Handle
h CgStream RawCmmGroup a
cmms = do
(r, s) <- NCGConfig
-> Platform
-> CgStream RawCmmGroup a
-> UniqDSMT IO (a, WasmCodeGenState 'I32)
forall a.
NCGConfig
-> Platform
-> CgStream RawCmmGroup a
-> UniqDSMT IO (a, WasmCodeGenState 'I32)
streamCmmGroups NCGConfig
ncg_config Platform
platform CgStream RawCmmGroup a
cmms
outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
let cfg = (WasmCodeGenState 'I32 -> WasmAsmConfig
forall (w :: WasmType). WasmCodeGenState w -> WasmAsmConfig
defaultWasmAsmConfig WasmCodeGenState 'I32
s) { pic = ncgPIC ncg_config, tailcall = doTailCall ts }
outputWasm $ execWasmAsmM cfg $ asmTellEverything TagI32 s
pure r
where
outputWasm :: Builder -> UniqDSMT IO ()
outputWasm Builder
builder = IO () -> UniqDSMT IO ()
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UniqDSMT IO ()) -> IO () -> UniqDSMT IO ()
forall a b. (a -> b) -> a -> b
$ do
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe
Logger
logger
DumpFlag
Opt_D_dump_asm
String
"Asm Code"
DumpFormat
FormatASM
(String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (LazyByteString -> String) -> LazyByteString -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> String
unpack (LazyByteString -> SDoc) -> LazyByteString -> SDoc
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
toLazyByteString Builder
builder)
Handle -> Builder -> IO ()
hPutBuilder Handle
h Builder
builder
streamCmmGroups ::
NCGConfig ->
Platform ->
CgStream RawCmmGroup a ->
UniqDSMT IO (a, WasmCodeGenState 'I32)
streamCmmGroups :: forall a.
NCGConfig
-> Platform
-> CgStream RawCmmGroup a
-> UniqDSMT IO (a, WasmCodeGenState 'I32)
streamCmmGroups NCGConfig
ncg_config Platform
platform CgStream RawCmmGroup a
cmms = (DUniqSupply -> IO ((a, WasmCodeGenState 'I32), DUniqSupply))
-> UniqDSMT IO (a, WasmCodeGenState 'I32)
forall a. (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a
withDUS ((DUniqSupply -> IO ((a, WasmCodeGenState 'I32), DUniqSupply))
-> UniqDSMT IO (a, WasmCodeGenState 'I32))
-> (DUniqSupply -> IO ((a, WasmCodeGenState 'I32), DUniqSupply))
-> UniqDSMT IO (a, WasmCodeGenState 'I32)
forall a b. (a -> b) -> a -> b
$ \DUniqSupply
us -> do
(r,s) <- WasmCodeGenState 'I32
-> StreamS (UniqDSMT IO) RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
go (Platform -> DUniqSupply -> WasmCodeGenState 'I32
forall (w :: WasmType).
Platform -> DUniqSupply -> WasmCodeGenState w
initialWasmCodeGenState Platform
platform DUniqSupply
us) (StreamS (UniqDSMT IO) RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32))
-> StreamS (UniqDSMT IO) RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
forall a b. (a -> b) -> a -> b
$ CgStream RawCmmGroup a -> StreamS (UniqDSMT IO) RawCmmGroup a
forall (m :: * -> *) r' r.
Applicative m =>
Stream m r' r -> StreamS m r' r
runStream CgStream RawCmmGroup a
cmms
return ((r,s), wasmDUniqSupply s)
where
go :: WasmCodeGenState 'I32
-> StreamS (UniqDSMT IO) RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
go WasmCodeGenState 'I32
s (Done a
r) = (a, WasmCodeGenState 'I32) -> IO (a, WasmCodeGenState 'I32)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
r, WasmCodeGenState 'I32
s)
go WasmCodeGenState 'I32
s (Effect UniqDSMT IO (StreamS (UniqDSMT IO) RawCmmGroup a)
m) = do
(a, us') <- DUniqSupply
-> UniqDSMT IO (StreamS (UniqDSMT IO) RawCmmGroup a)
-> IO (StreamS (UniqDSMT IO) RawCmmGroup a, DUniqSupply)
forall (m :: * -> *) a.
DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)
runUDSMT (WasmCodeGenState 'I32 -> DUniqSupply
forall (w :: WasmType). WasmCodeGenState w -> DUniqSupply
wasmDUniqSupply WasmCodeGenState 'I32
s) UniqDSMT IO (StreamS (UniqDSMT IO) RawCmmGroup a)
m
go s{wasmDUniqSupply = us'} a
go WasmCodeGenState 'I32
s (Yield RawCmmGroup
decls StreamS (UniqDSMT IO) RawCmmGroup a
k) = WasmCodeGenState 'I32
-> StreamS (UniqDSMT IO) RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
go (WasmCodeGenM 'I32 ()
-> WasmCodeGenState 'I32 -> WasmCodeGenState 'I32
forall (w :: WasmType) a.
WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM (RawCmmGroup -> WasmCodeGenM 'I32 ()
forall (w :: WasmType). RawCmmGroup -> WasmCodeGenM w ()
onCmmGroup (RawCmmGroup -> WasmCodeGenM 'I32 ())
-> RawCmmGroup -> WasmCodeGenM 'I32 ()
forall a b. (a -> b) -> a -> b
$ (GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph)
-> RawCmmGroup -> RawCmmGroup
forall a b. (a -> b) -> [a] -> [b]
map GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
opt RawCmmGroup
decls) WasmCodeGenState 'I32
s) StreamS (UniqDSMT IO) RawCmmGroup a
k
where
opt :: GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
opt GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl = case GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl of
CmmData {} -> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl
CmmProc {} -> LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live (CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph)
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall a b. (a -> b) -> a -> b
$ Bool -> CmmGraph -> CmmGraph
cmmCfgOpts Bool
False CmmGraph
graph
where
(CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live CmmGraph
graph, [CLabel]
_) = NCGConfig
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-> (GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph,
[CLabel])
cmmToCmm NCGConfig
ncg_config GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
decl
doTailCall :: ToolSettings -> Bool
doTailCall :: ToolSettings -> Bool
doTailCall ToolSettings
ts = String -> Option
Option String
"-mtail-call" Option -> [Option] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Option]
as_args
where
(String
_, [Option]
as_args) = ToolSettings -> (String, [Option])
toolSettings_pgm_a ToolSettings
ts