{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}

module GHC.CmmToAsm.Wasm (ncgWasm) where

import Data.ByteString.Builder
import Data.Maybe
import Data.Semigroup
import GHC.Cmm
import GHC.CmmToAsm.Wasm.Asm
import GHC.CmmToAsm.Wasm.FromCmm
import GHC.CmmToAsm.Wasm.Types
import GHC.Data.Stream (Stream, StreamS (..), runStream)
import GHC.Platform
import GHC.Prelude
import GHC.Settings
import GHC.Types.Unique.Supply
import GHC.Unit
import GHC.Utils.CliOption
import System.IO

ncgWasm ::
  Platform ->
  ToolSettings ->
  UniqSupply ->
  ModLocation ->
  Handle ->
  Stream IO RawCmmGroup a ->
  IO a
ncgWasm :: forall a.
Platform
-> ToolSettings
-> UniqSupply
-> ModLocation
-> Handle
-> Stream IO RawCmmGroup a
-> IO a
ncgWasm Platform
platform ToolSettings
ts UniqSupply
us ModLocation
loc Handle
h Stream IO RawCmmGroup a
cmms = do
  (a
r, WasmCodeGenState 'I32
s) <- Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
forall a.
Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
streamCmmGroups Platform
platform UniqSupply
us Stream IO RawCmmGroup a
cmms
  Handle -> Builder -> IO ()
hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder
"# " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7 (Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe String
ml_hs_file ModLocation
loc) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n\n"
  Handle -> Builder -> IO ()
hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> WasmAsmM () -> Builder
forall a. Bool -> WasmAsmM a -> Builder
execWasmAsmM Bool
do_tail_call (WasmAsmM () -> Builder) -> WasmAsmM () -> Builder
forall a b. (a -> b) -> a -> b
$ WasmTypeTag 'I32 -> WasmCodeGenState 'I32 -> WasmAsmM ()
forall (w :: WasmType).
WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()
asmTellEverything WasmTypeTag 'I32
TagI32 WasmCodeGenState 'I32
s
  a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
  where
    -- See Note [WasmTailCall]
    do_tail_call :: Bool
do_tail_call = ToolSettings -> Bool
doTailCall ToolSettings
ts

streamCmmGroups ::
  Platform ->
  UniqSupply ->
  Stream IO RawCmmGroup a ->
  IO (a, WasmCodeGenState 'I32)
streamCmmGroups :: forall a.
Platform
-> UniqSupply
-> Stream IO RawCmmGroup a
-> IO (a, WasmCodeGenState 'I32)
streamCmmGroups Platform
platform UniqSupply
us Stream IO RawCmmGroup a
cmms =
  WasmCodeGenState 'I32
-> StreamS IO RawCmmGroup a -> IO (a, WasmCodeGenState 'I32)
forall {f :: * -> *} {w :: WasmType} {a}.
Monad f =>
WasmCodeGenState w
-> StreamS f RawCmmGroup a -> f (a, WasmCodeGenState w)
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 w
-> StreamS f RawCmmGroup a -> f (a, WasmCodeGenState w)
go WasmCodeGenState w
s (Done a
r) = (a, WasmCodeGenState w) -> f (a, WasmCodeGenState w)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
r, WasmCodeGenState w
s)
    go WasmCodeGenState w
s (Effect f (StreamS f RawCmmGroup a)
m) = f (StreamS f RawCmmGroup a)
m f (StreamS f RawCmmGroup a)
-> (StreamS f RawCmmGroup a -> f (a, WasmCodeGenState w))
-> f (a, WasmCodeGenState w)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WasmCodeGenState w
-> StreamS f RawCmmGroup a -> f (a, WasmCodeGenState w)
go WasmCodeGenState w
s
    go WasmCodeGenState w
s (Yield RawCmmGroup
cmm StreamS f RawCmmGroup a
k) = WasmCodeGenState w
-> StreamS f RawCmmGroup a -> f (a, WasmCodeGenState w)
go (WasmCodeGenM w () -> WasmCodeGenState w -> WasmCodeGenState w
forall (w :: WasmType) a.
WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM (RawCmmGroup -> WasmCodeGenM w ()
forall (w :: WasmType). RawCmmGroup -> WasmCodeGenM w ()
onCmmGroup RawCmmGroup
cmm) WasmCodeGenState w
s) StreamS f RawCmmGroup a
k

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