{-# 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.Data.Stream (Stream, StreamS (..), runStream)
import GHC.Driver.DynFlags
import GHC.Platform
import GHC.Prelude
import GHC.Settings
import GHC.Types.Unique.Supply
import GHC.Unit
import GHC.Utils.Logger
import GHC.Utils.Outputable (text)
import System.IO

ncgWasm ::
  NCGConfig ->
  Logger ->
  Platform ->
  ToolSettings ->
  UniqSupply ->
  ModLocation ->
  Handle ->
  Stream IO RawCmmGroup a ->
  IO a
ncgWasm :: forall a.
NCGConfig
-> Logger
-> Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
ncgWasm NCGConfig
ncg_config Logger
logger Platform
platform ToolSettings
ts UniqSupply
us ModLocation
loc Handle
h Stream IO RawCmmGroup a
cmms = do
  (r, s) <- NCGConfig
-> Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
forall a.
NCGConfig
-> Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
streamCmmGroups NCGConfig
ncg_config Platform
platform UniqSupply
us Stream IO RawCmmGroup a
cmms
  outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
  outputWasm $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s
  pure r
  where
    -- See Note [WasmTailCall]
    do_tail_call :: Bool
do_tail_call = ToolSettings -> Bool
doTailCall ToolSettings
ts

    outputWasm :: Builder -> IO ()
outputWasm Builder
builder = 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 ->
  UniqSupply ->
  Stream IO RawCmmGroup a ->
  IO (a, WasmCodeGenState 'I32)
streamCmmGroups :: forall a.
NCGConfig
-> Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
streamCmmGroups NCGConfig
ncg_config Platform
platform UniqSupply
us Stream IO RawCmmGroup a
cmms =
  WasmCodeGenState 'I32
-> StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32)
go (Platform -> UniqSupply -> WasmCodeGenState 'I32
forall (w :: WasmType).
Platform -> UniqSupply -> WasmCodeGenState w
initialWasmCodeGenState Platform
platform UniqSupply
us) (StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32))
-> StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32)
forall a b. (a -> b) -> a -> b
$ Stream IO RawCmmGroup a -> StreamS IO RawCmmGroup a
forall (m :: * -> *) r' r.
Applicative m =>
Stream m r' r -> StreamS m r' r
runStream Stream IO RawCmmGroup a
cmms
  where
    go :: WasmCodeGenState 'I32
-> StreamS 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 IO (StreamS IO RawCmmGroup a)
m) = IO (StreamS IO RawCmmGroup a)
m IO (StreamS IO RawCmmGroup a)
-> (StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32))
-> IO (a, WasmCodeGenState 'I32)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WasmCodeGenState 'I32
-> StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32)
go WasmCodeGenState 'I32
s
    go WasmCodeGenState 'I32
s (Yield RawCmmGroup
decls StreamS IO RawCmmGroup a
k) = WasmCodeGenState 'I32
-> StreamS 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 IO RawCmmGroup a
k
      where
        -- Run the generic cmm optimizations like other NCGs, followed
        -- by a late control-flow optimization pass that does shrink
        -- the CFG block count in some cases.
        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
-> [GlobalReg]
-> CmmGraph
-> GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
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 [GlobalReg]
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