{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where

import Control.Monad
import Control.Monad.Trans.Reader
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import Data.Coerce
import Data.Foldable
import qualified Data.IntSet as IS
import Data.Maybe
import Data.Semigroup
import GHC.Cmm
import GHC.CmmToAsm.Ppr
import GHC.CmmToAsm.Wasm.FromCmm
import GHC.CmmToAsm.Wasm.Types
import GHC.CmmToAsm.Wasm.Utils
import GHC.Data.FastString
import GHC.Float
import GHC.Prelude
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Types.Unique.Map
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Outputable hiding ((<>))
import GHC.Utils.Panic (panic)

-- | Reads current indentation, appends result to state
newtype WasmAsmM a = WasmAsmM (Builder -> State Builder a)
  deriving
    ( forall a b. a -> WasmAsmM b -> WasmAsmM a
forall a b. (a -> b) -> WasmAsmM a -> WasmAsmM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WasmAsmM b -> WasmAsmM a
$c<$ :: forall a b. a -> WasmAsmM b -> WasmAsmM a
fmap :: forall a b. (a -> b) -> WasmAsmM a -> WasmAsmM b
$cfmap :: forall a b. (a -> b) -> WasmAsmM a -> WasmAsmM b
Functor,
      Functor WasmAsmM
forall a. a -> WasmAsmM a
forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM a
forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
forall a b. WasmAsmM (a -> b) -> WasmAsmM a -> WasmAsmM b
forall a b c.
(a -> b -> c) -> WasmAsmM a -> WasmAsmM b -> WasmAsmM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM a
$c<* :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM a
*> :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
$c*> :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
liftA2 :: forall a b c.
(a -> b -> c) -> WasmAsmM a -> WasmAsmM b -> WasmAsmM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> WasmAsmM a -> WasmAsmM b -> WasmAsmM c
<*> :: forall a b. WasmAsmM (a -> b) -> WasmAsmM a -> WasmAsmM b
$c<*> :: forall a b. WasmAsmM (a -> b) -> WasmAsmM a -> WasmAsmM b
pure :: forall a. a -> WasmAsmM a
$cpure :: forall a. a -> WasmAsmM a
Applicative,
      Applicative WasmAsmM
forall a. a -> WasmAsmM a
forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
forall a b. WasmAsmM a -> (a -> WasmAsmM b) -> WasmAsmM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> WasmAsmM a
$creturn :: forall a. a -> WasmAsmM a
>> :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
$c>> :: forall a b. WasmAsmM a -> WasmAsmM b -> WasmAsmM b
>>= :: forall a b. WasmAsmM a -> (a -> WasmAsmM b) -> WasmAsmM b
$c>>= :: forall a b. WasmAsmM a -> (a -> WasmAsmM b) -> WasmAsmM b
Monad
    )
    via (ReaderT Builder (State Builder))

instance Semigroup a => Semigroup (WasmAsmM a) where
  <> :: WasmAsmM a -> WasmAsmM a -> WasmAsmM a
(<>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (WasmAsmM a) where
  mempty :: WasmAsmM a
mempty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty

-- | Default indent level is none
execWasmAsmM :: WasmAsmM a -> Builder
execWasmAsmM :: forall a. WasmAsmM a -> Builder
execWasmAsmM (WasmAsmM Builder -> State Builder a
m) = forall s a. State s a -> s -> s
execState (Builder -> State Builder a
m forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty

-- | Increase indent level by a tab
asmWithTab :: WasmAsmM a -> WasmAsmM a
asmWithTab :: forall a. WasmAsmM a -> WasmAsmM a
asmWithTab (WasmAsmM Builder -> State Builder a
m) = forall a. (Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Builder
t -> Builder -> State Builder a
m forall a b. (a -> b) -> a -> b
$! Char -> Builder
char7 Char
'\t' forall a. Semigroup a => a -> a -> a
<> Builder
t

-- | Writes a single line starting with the current indent
asmTellLine :: Builder -> WasmAsmM ()
asmTellLine :: Builder -> WasmAsmM ()
asmTellLine Builder
b = forall a. (Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Builder
t -> forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \Builder
acc -> Builder
acc forall a. Semigroup a => a -> a -> a
<> Builder
t forall a. Semigroup a => a -> a -> a
<> Builder
b forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\n'

-- | Writes a single line break
asmTellLF :: WasmAsmM ()
asmTellLF :: WasmAsmM ()
asmTellLF = forall a. (Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Builder
_ -> forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \Builder
acc -> Builder
acc forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\n'

-- | Writes a line starting with a single tab, ignoring current indent
-- level
asmTellTabLine :: Builder -> WasmAsmM ()
asmTellTabLine :: Builder -> WasmAsmM ()
asmTellTabLine Builder
b =
  forall a. (Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Builder
_ -> forall s. (s -> s) -> State s ()
modify forall a b. (a -> b) -> a -> b
$ \Builder
acc -> Builder
acc forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\t' forall a. Semigroup a => a -> a -> a
<> Builder
b forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'\n'

asmFromWasmType :: WasmTypeTag t -> Builder
asmFromWasmType :: forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty = case WasmTypeTag t
ty of
  WasmTypeTag t
TagI32 -> Builder
"i32"
  WasmTypeTag t
TagI64 -> Builder
"i64"
  WasmTypeTag t
TagF32 -> Builder
"f32"
  WasmTypeTag t
TagF64 -> Builder
"f64"

asmFromSomeWasmType :: SomeWasmType -> Builder
asmFromSomeWasmType :: SomeWasmType -> Builder
asmFromSomeWasmType (SomeWasmType WasmTypeTag t
t) = forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
t

asmFromSomeWasmTypes :: [SomeWasmType] -> Builder
asmFromSomeWasmTypes :: [SomeWasmType] -> Builder
asmFromSomeWasmTypes [SomeWasmType]
ts = Builder
"(" forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Builder) -> [a] -> Builder
builderCommas SomeWasmType -> Builder
asmFromSomeWasmType [SomeWasmType]
ts forall a. Semigroup a => a -> a -> a
<> Builder
")"

asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder
asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder
asmFromFuncType [SomeWasmType]
arg_tys [SomeWasmType]
ret_tys =
  [SomeWasmType] -> Builder
asmFromSomeWasmTypes [SomeWasmType]
arg_tys forall a. Semigroup a => a -> a -> a
<> Builder
" -> " forall a. Semigroup a => a -> a -> a
<> [SomeWasmType] -> Builder
asmFromSomeWasmTypes [SomeWasmType]
ret_tys

asmTellFuncType ::
  SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()
asmTellFuncType :: SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()
asmTellFuncType SymName
sym ([SomeWasmType]
arg_tys, [SomeWasmType]
ret_tys) =
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$
    Builder
".functype "
      forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
      forall a. Semigroup a => a -> a -> a
<> Builder
" "
      forall a. Semigroup a => a -> a -> a
<> [SomeWasmType] -> [SomeWasmType] -> Builder
asmFromFuncType [SomeWasmType]
arg_tys [SomeWasmType]
ret_tys

asmTellLocals :: [SomeWasmType] -> WasmAsmM ()
asmTellLocals :: [SomeWasmType] -> WasmAsmM ()
asmTellLocals [] = forall a. Monoid a => a
mempty
asmTellLocals [SomeWasmType]
local_tys =
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".local " forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Builder) -> [a] -> Builder
builderCommas SomeWasmType -> Builder
asmFromSomeWasmType [SomeWasmType]
local_tys

asmFromSymName :: SymName -> Builder
asmFromSymName :: SymName -> Builder
asmFromSymName = ShortByteString -> Builder
shortByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce FastString -> ShortByteString
fastStringToShortByteString

asmTellDefSym :: SymName -> WasmAsmM ()
asmTellDefSym :: SymName -> WasmAsmM ()
asmTellDefSym SymName
sym = do
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".hidden " forall a. Semigroup a => a -> a -> a
<> Builder
asm_sym
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".globl " forall a. Semigroup a => a -> a -> a
<> Builder
asm_sym
  where
    asm_sym :: Builder
asm_sym = SymName -> Builder
asmFromSymName SymName
sym

asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM ()
asmTellDataSectionContent :: forall (w :: WasmType).
WasmTypeTag w -> DataSectionContent -> WasmAsmM ()
asmTellDataSectionContent WasmTypeTag w
ty_word DataSectionContent
c = Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ case DataSectionContent
c of
  DataI8 Integer
i -> Builder
".int8 " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  DataI16 Integer
i -> Builder
".int16 " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  DataI32 Integer
i -> Builder
".int32 " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  DataI64 Integer
i -> Builder
".int64 " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  DataF32 Float
f -> Builder
".int32 0x" forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32Hex (Float -> Word32
castFloatToWord32 Float
f)
  DataF64 Double
d -> Builder
".int64 0x" forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Hex (Double -> Word64
castDoubleToWord64 Double
d)
  DataSym SymName
sym Int
o ->
    ( case WasmTypeTag w
ty_word of
        WasmTypeTag w
TagI32 -> Builder
".int32 "
        WasmTypeTag w
TagI64 -> Builder
".int64 "
        WasmTypeTag w
_ -> forall a. HasCallStack => String -> a
panic String
"asmTellDataSectionContent: unreachable"
    )
      forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
      forall a. Semigroup a => a -> a -> a
<> ( case forall a. Ord a => a -> a -> Ordering
compare Int
o Int
0 of
             Ordering
EQ -> forall a. Monoid a => a
mempty
             Ordering
GT -> Builder
"+" forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
o
             Ordering
LT -> Int -> Builder
intDec Int
o
         )
  DataSkip Int
i -> Builder
".skip " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
i
  DataASCII ByteString
s
    | Bool -> Bool
not (ByteString -> Bool
BS.null ByteString
s) Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
BS.last ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
0 ->
        Builder
".asciz \""
          forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7
            (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => ByteString -> doc
pprASCII forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
BS.init ByteString
s)
          forall a. Semigroup a => a -> a -> a
<> Builder
"\""
    | Bool
otherwise ->
        Builder
".ascii \""
          forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7
            (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => ByteString -> doc
pprASCII ByteString
s)
          forall a. Semigroup a => a -> a -> a
<> Builder
"\""
  DataIncBin String
f Int
_ ->
    Builder
".incbin "
      forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7
        (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
pprFilePathString String
f)

dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int
dataSectionContentSize :: forall (w :: WasmType). WasmTypeTag w -> DataSectionContent -> Int
dataSectionContentSize WasmTypeTag w
ty_word DataSectionContent
c = case DataSectionContent
c of
  DataI8 {} -> Int
1
  DataI16 {} -> Int
2
  DataI32 {} -> Int
4
  DataI64 {} -> Int
8
  DataF32 {} -> Int
4
  DataF64 {} -> Int
8
  DataSym {} -> Alignment -> Int
alignmentBytes forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType). WasmTypeTag w -> Alignment
alignmentFromWordType WasmTypeTag w
ty_word
  DataSkip Int
i -> Int
i
  DataASCII ByteString
s -> ByteString -> Int
BS.length ByteString
s
  DataIncBin String
_ Int
l -> Int
l

dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int
dataSectionSize :: forall (w :: WasmType).
WasmTypeTag w -> [DataSectionContent] -> Int
dataSectionSize WasmTypeTag w
ty_word =
  coerce :: forall a b. Coercible a b => a -> b
coerce
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap'
      (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (w :: WasmType). WasmTypeTag w -> DataSectionContent -> Int
dataSectionContentSize WasmTypeTag w
ty_word)

asmTellAlign :: Alignment -> WasmAsmM ()
asmTellAlign :: Alignment -> WasmAsmM ()
asmTellAlign Alignment
a = case Alignment -> Int
alignmentBytes Alignment
a of
  Int
1 -> forall a. Monoid a => a
mempty
  Int
i -> Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".p2align " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (forall b. FiniteBits b => b -> Int
countTrailingZeros Int
i)

asmTellSectionHeader :: Builder -> WasmAsmM ()
asmTellSectionHeader :: Builder -> WasmAsmM ()
asmTellSectionHeader Builder
k = Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".section " forall a. Semigroup a => a -> a -> a
<> Builder
k forall a. Semigroup a => a -> a -> a
<> Builder
",\"\",@"

asmTellDataSection ::
  WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM ()
asmTellDataSection :: forall (w :: WasmType).
WasmTypeTag w -> IntSet -> SymName -> DataSection -> WasmAsmM ()
asmTellDataSection WasmTypeTag w
ty_word IntSet
def_syms SymName
sym DataSection {[DataSectionContent]
Alignment
DataSectionKind
dataSectionContents :: DataSection -> [DataSectionContent]
dataSectionAlignment :: DataSection -> Alignment
dataSectionKind :: DataSection -> DataSectionKind
dataSectionContents :: [DataSectionContent]
dataSectionAlignment :: Alignment
dataSectionKind :: DataSectionKind
..} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unique -> Int
getKey (forall a. Uniquable a => a -> Unique
getUnique SymName
sym) Int -> IntSet -> Bool
`IS.member` IntSet
def_syms) forall a b. (a -> b) -> a -> b
$ SymName -> WasmAsmM ()
asmTellDefSym SymName
sym
  Builder -> WasmAsmM ()
asmTellSectionHeader Builder
sec_name
  Alignment -> WasmAsmM ()
asmTellAlign Alignment
dataSectionAlignment
  Builder -> WasmAsmM ()
asmTellTabLine Builder
asm_size
  Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
asm_sym forall a. Semigroup a => a -> a -> a
<> Builder
":"
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [DataSectionContent]
dataSectionContents forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType).
WasmTypeTag w -> DataSectionContent -> WasmAsmM ()
asmTellDataSectionContent WasmTypeTag w
ty_word
  WasmAsmM ()
asmTellLF
  where
    asm_sym :: Builder
asm_sym = SymName -> Builder
asmFromSymName SymName
sym

    sec_name :: Builder
sec_name =
      ( case DataSectionKind
dataSectionKind of
          DataSectionKind
SectionData -> Builder
".data."
          DataSectionKind
SectionROData -> Builder
".rodata."
      )
        forall a. Semigroup a => a -> a -> a
<> Builder
asm_sym

    asm_size :: Builder
asm_size =
      Builder
".size "
        forall a. Semigroup a => a -> a -> a
<> Builder
asm_sym
        forall a. Semigroup a => a -> a -> a
<> Builder
", "
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec
          (forall (w :: WasmType).
WasmTypeTag w -> [DataSectionContent] -> Int
dataSectionSize WasmTypeTag w
ty_word [DataSectionContent]
dataSectionContents)

asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder
asmFromWasmBlockType :: forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmFunctionType pre post -> Builder
asmFromWasmBlockType
  WasmTypeTag w
_
  (WasmFunctionType {ft_pops :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList pre
ft_pops = TypeList pre
TypeListNil, ft_pushes :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList post
ft_pushes = TypeList post
TypeListNil}) =
    forall a. Monoid a => a
mempty
asmFromWasmBlockType
  WasmTypeTag w
TagI32
  ( WasmFunctionType
      { ft_pops :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList pre
ft_pops = TypeList pre
TypeListNil,
        ft_pushes :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList post
ft_pushes = TypeListCons WasmTypeTag t
TagI32 TypeList ts
TypeListNil
      }
    ) =
    Builder
" i32"
asmFromWasmBlockType
  WasmTypeTag w
TagI64
  ( WasmFunctionType
      { ft_pops :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList pre
ft_pops = TypeList pre
TypeListNil,
        ft_pushes :: forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList post
ft_pushes = TypeListCons WasmTypeTag t
TagI64 TypeList ts
TypeListNil
      }
    ) =
    Builder
" i64"
asmFromWasmBlockType WasmTypeTag w
_ WasmFunctionType pre post
_ = forall a. HasCallStack => String -> a
panic String
"asmFromWasmBlockType: invalid block type"

asmFromAlignmentSpec :: AlignmentSpec -> Builder
asmFromAlignmentSpec :: AlignmentSpec -> Builder
asmFromAlignmentSpec AlignmentSpec
NaturallyAligned = forall a. Monoid a => a
mempty
asmFromAlignmentSpec AlignmentSpec
Unaligned = Builder
":p2align=0"

asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr :: forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word WasmInstr w pre post
instr = case WasmInstr w pre post
instr of
  WasmComment String
c -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ String -> Builder
stringUtf8 forall a b. (a -> b) -> a -> b
$ String
"# " forall a. Semigroup a => a -> a -> a
<> String
c
  WasmInstr w pre post
WasmNop -> forall a. Monoid a => a
mempty
  WasmInstr w pre post
WasmDrop -> Builder -> WasmAsmM ()
asmTellLine Builder
"drop"
  WasmInstr w pre post
WasmUnreachable -> Builder -> WasmAsmM ()
asmTellLine Builder
"unreachable"
  WasmConst WasmTypeTag t
TagI32 Integer
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"i32.const " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  WasmConst WasmTypeTag t
TagI64 Integer
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"i64.const " forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
integerDec Integer
i
  WasmConst {} -> forall a. HasCallStack => String -> a
panic String
"asmTellWasmInstr: unreachable"
  WasmSymConst SymName
sym ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      ( case WasmTypeTag w
ty_word of
          WasmTypeTag w
TagI32 -> Builder
"i32.const "
          WasmTypeTag w
TagI64 -> Builder
"i64.const "
          WasmTypeTag w
_ -> forall a. HasCallStack => String -> a
panic String
"asmTellWasmInstr: unreachable"
      )
        forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
  WasmLoad WasmTypeTag t
ty (Just Int
w) Signage
s Int
o AlignmentSpec
align ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty
        forall a. Semigroup a => a -> a -> a
<> Builder
".load"
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
w
        forall a. Semigroup a => a -> a -> a
<> ( case Signage
s of
               Signage
Signed -> Builder
"_s"
               Signage
Unsigned -> Builder
"_u"
           )
        forall a. Semigroup a => a -> a -> a
<> Builder
" "
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
o
        forall a. Semigroup a => a -> a -> a
<> AlignmentSpec -> Builder
asmFromAlignmentSpec AlignmentSpec
align
  WasmLoad WasmTypeTag t
ty Maybe Int
Nothing Signage
_ Int
o AlignmentSpec
align ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty
        forall a. Semigroup a => a -> a -> a
<> Builder
".load"
        forall a. Semigroup a => a -> a -> a
<> Builder
" "
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
o
        forall a. Semigroup a => a -> a -> a
<> AlignmentSpec -> Builder
asmFromAlignmentSpec AlignmentSpec
align
  WasmStore WasmTypeTag t
ty (Just Int
w) Int
o AlignmentSpec
align ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty
        forall a. Semigroup a => a -> a -> a
<> Builder
".store"
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
w
        forall a. Semigroup a => a -> a -> a
<> Builder
" "
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
o
        forall a. Semigroup a => a -> a -> a
<> AlignmentSpec -> Builder
asmFromAlignmentSpec AlignmentSpec
align
  WasmStore WasmTypeTag t
ty Maybe Int
Nothing Int
o AlignmentSpec
align ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty
        forall a. Semigroup a => a -> a -> a
<> Builder
".store"
        forall a. Semigroup a => a -> a -> a
<> Builder
" "
        forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
o
        forall a. Semigroup a => a -> a -> a
<> AlignmentSpec -> Builder
asmFromAlignmentSpec AlignmentSpec
align
  WasmGlobalGet WasmTypeTag t
_ SymName
sym -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"global.get " forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
  WasmGlobalSet WasmTypeTag t
_ SymName
sym -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"global.set " forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
  WasmLocalGet WasmTypeTag t
_ Int
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"local.get " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
i
  WasmLocalSet WasmTypeTag t
_ Int
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"local.set " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
i
  WasmLocalTee WasmTypeTag t
_ Int
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"local.tee " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
i
  WasmCCall SymName
sym -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"call " forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
  WasmCCallIndirect TypeList arg_tys
arg_tys TypeList ret_tys
ret_tys ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      Builder
"call_indirect "
        forall a. Semigroup a => a -> a -> a
<> [SomeWasmType] -> [SomeWasmType] -> Builder
asmFromFuncType
          (forall (ts :: [WasmType]). TypeList ts -> [SomeWasmType]
someWasmTypesFromTypeList TypeList arg_tys
arg_tys)
          (forall (ts :: [WasmType]). TypeList ts -> [SomeWasmType]
someWasmTypesFromTypeList TypeList ret_tys
ret_tys)
  WasmConcat WasmInstr w pre mid
instr0 WasmInstr w mid post
instr1 -> do
    forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word WasmInstr w pre mid
instr0
    forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word WasmInstr w mid post
instr1
  WasmReinterpret WasmTypeTag t0
t0 WasmTypeTag t1
t1 ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t1
t1 forall a. Semigroup a => a -> a -> a
<> Builder
".reinterpret_" forall a. Semigroup a => a -> a -> a
<> forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t0
t0
  WasmTruncSat Signage
Signed WasmTypeTag t0
t0 WasmTypeTag t1
t1 ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t1
t1 forall a. Semigroup a => a -> a -> a
<> Builder
".trunc_sat_" forall a. Semigroup a => a -> a -> a
<> forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t0
t0 forall a. Semigroup a => a -> a -> a
<> Builder
"_s"
  WasmTruncSat Signage
Unsigned WasmTypeTag t0
t0 WasmTypeTag t1
t1 ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t1
t1 forall a. Semigroup a => a -> a -> a
<> Builder
".trunc_sat_" forall a. Semigroup a => a -> a -> a
<> forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t0
t0 forall a. Semigroup a => a -> a -> a
<> Builder
"_u"
  WasmConvert Signage
Signed WasmTypeTag t0
t0 WasmTypeTag t1
t1 ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t1
t1 forall a. Semigroup a => a -> a -> a
<> Builder
".convert_" forall a. Semigroup a => a -> a -> a
<> forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t0
t0 forall a. Semigroup a => a -> a -> a
<> Builder
"_s"
  WasmConvert Signage
Unsigned WasmTypeTag t0
t0 WasmTypeTag t1
t1 ->
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$
      forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t1
t1 forall a. Semigroup a => a -> a -> a
<> Builder
".convert_" forall a. Semigroup a => a -> a -> a
<> forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t0
t0 forall a. Semigroup a => a -> a -> a
<> Builder
"_u"
  WasmAdd WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".add"
  WasmSub WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".sub"
  WasmMul WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".mul"
  WasmDiv Signage
_ WasmTypeTag t
TagF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.div"
  WasmDiv Signage
_ WasmTypeTag t
TagF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.div"
  WasmDiv Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".div_s"
  WasmDiv Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".div_u"
  WasmRem Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".rem_s"
  WasmRem Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".rem_u"
  WasmAnd WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".and"
  WasmOr WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".or"
  WasmXor WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".xor"
  WasmEq WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".eq"
  WasmNe WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".ne"
  WasmLt Signage
_ WasmTypeTag t
TagF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.lt"
  WasmLt Signage
_ WasmTypeTag t
TagF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.lt"
  WasmLt Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".lt_s"
  WasmLt Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".lt_u"
  WasmGt Signage
_ WasmTypeTag t
TagF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.gt"
  WasmGt Signage
_ WasmTypeTag t
TagF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.gt"
  WasmGt Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".gt_s"
  WasmGt Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".gt_u"
  WasmLe Signage
_ WasmTypeTag t
TagF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.le"
  WasmLe Signage
_ WasmTypeTag t
TagF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.le"
  WasmLe Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".le_s"
  WasmLe Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".le_u"
  WasmGe Signage
_ WasmTypeTag t
TagF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.ge"
  WasmGe Signage
_ WasmTypeTag t
TagF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.ge"
  WasmGe Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".ge_s"
  WasmGe Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".ge_u"
  WasmShl WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".shl"
  WasmShr Signage
Signed WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".shr_s"
  WasmShr Signage
Unsigned WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".shr_u"
  WasmInstr w pre post
WasmI32Extend8S -> Builder -> WasmAsmM ()
asmTellLine Builder
"i32.extend8_s"
  WasmInstr w pre post
WasmI32Extend16S -> Builder -> WasmAsmM ()
asmTellLine Builder
"i32.extend16_s"
  WasmInstr w pre post
WasmI64Extend8S -> Builder -> WasmAsmM ()
asmTellLine Builder
"i64.extend8_s"
  WasmInstr w pre post
WasmI64Extend16S -> Builder -> WasmAsmM ()
asmTellLine Builder
"i64.extend16_s"
  WasmInstr w pre post
WasmI64Extend32S -> Builder -> WasmAsmM ()
asmTellLine Builder
"i64.extend32_s"
  WasmI64ExtendI32 Signage
Signed -> Builder -> WasmAsmM ()
asmTellLine Builder
"i64.extend_i32_s"
  WasmI64ExtendI32 Signage
Unsigned -> Builder -> WasmAsmM ()
asmTellLine Builder
"i64.extend_i32_u"
  WasmInstr w pre post
WasmI32WrapI64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"i32.wrap_i64"
  WasmInstr w pre post
WasmF32DemoteF64 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f32.demote_f64"
  WasmInstr w pre post
WasmF64PromoteF32 -> Builder -> WasmAsmM ()
asmTellLine Builder
"f64.promote_f32"
  WasmAbs WasmTypeTag t
ty -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ forall (t :: WasmType). WasmTypeTag t -> Builder
asmFromWasmType WasmTypeTag t
ty forall a. Semigroup a => a -> a -> a
<> Builder
".abs"
  WasmCond WasmInstr w post post
t -> do
    Builder -> WasmAsmM ()
asmTellLine Builder
"if"
    forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word WasmInstr w post post
t
    Builder -> WasmAsmM ()
asmTellLine Builder
"end_if"

asmTellWasmControl ::
  WasmTypeTag w ->
  WasmControl
    (WasmStatements w)
    (WasmExpr w a)
    pre
    post ->
  WasmAsmM ()
asmTellWasmControl :: forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre post
c = case WasmControl (WasmStatements w) (WasmExpr w a) pre post
c of
  WasmPush WasmTypeTag t
_ (WasmExpr forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e) -> forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e
  WasmBlock WasmFunctionType pre post
bt WasmControl (WasmStatements w) (WasmExpr w a) pre post
c -> do
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"block" forall a. Semigroup a => a -> a -> a
<> forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmFunctionType pre post -> Builder
asmFromWasmBlockType WasmTypeTag w
ty_word WasmFunctionType pre post
bt
    forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre post
c
    Builder -> WasmAsmM ()
asmTellLine Builder
"end_block"
  WasmLoop WasmFunctionType pre post
bt WasmControl (WasmStatements w) (WasmExpr w a) pre post
c -> do
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"loop" forall a. Semigroup a => a -> a -> a
<> forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmFunctionType pre post -> Builder
asmFromWasmBlockType WasmTypeTag w
ty_word WasmFunctionType pre post
bt
    forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre post
c
    -- asmTellLine "br 0"
    Builder -> WasmAsmM ()
asmTellLine Builder
"end_loop"
  WasmIfTop WasmFunctionType pre post
bt WasmControl (WasmStatements w) (WasmExpr w a) pre post
t WasmControl (WasmStatements w) (WasmExpr w a) pre post
f -> do
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"if" forall a. Semigroup a => a -> a -> a
<> forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmFunctionType pre post -> Builder
asmFromWasmBlockType WasmTypeTag w
ty_word WasmFunctionType pre post
bt
    forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre post
t
    Builder -> WasmAsmM ()
asmTellLine Builder
"else"
    forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre post
f
    Builder -> WasmAsmM ()
asmTellLine Builder
"end_if"
  WasmBr Int
i -> Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"br " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
i
  WasmControl (WasmStatements w) (WasmExpr w a) pre post
WasmFallthrough -> forall a. Monoid a => a
mempty
  WasmBrTable (WasmExpr forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e) BrTableInterval
_ [Int]
ts Int
t -> do
    forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e
    Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"br_table {" forall a. Semigroup a => a -> a -> a
<> forall a. (a -> Builder) -> [a] -> Builder
builderCommas Int -> Builder
intDec ([Int]
ts forall a. Semigroup a => a -> a -> a
<> [Int
t]) forall a. Semigroup a => a -> a -> a
<> Builder
"}"
  WasmReturnTop WasmTypeTag t
_ -> Builder -> WasmAsmM ()
asmTellLine Builder
"return"
  WasmActions (WasmStatements forall (pre :: [WasmType]). WasmInstr w pre pre
a) -> forall (w :: WasmType) (pre :: [WasmType]) (post :: [WasmType]).
WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
asmTellWasmInstr WasmTypeTag w
ty_word forall (pre :: [WasmType]). WasmInstr w pre pre
a
  WasmSeq WasmControl (WasmStatements w) (WasmExpr w a) pre mid
c0 WasmControl (WasmStatements w) (WasmExpr w a) mid post
c1 -> do
    forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) pre mid
c0
    forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w a) mid post
c1

asmTellFunc ::
  WasmTypeTag w ->
  IS.IntSet ->
  SymName ->
  (([SomeWasmType], [SomeWasmType]), FuncBody w) ->
  WasmAsmM ()
asmTellFunc :: forall (w :: WasmType).
WasmTypeTag w
-> IntSet
-> SymName
-> (([SomeWasmType], [SomeWasmType]), FuncBody w)
-> WasmAsmM ()
asmTellFunc WasmTypeTag w
ty_word IntSet
def_syms SymName
sym (([SomeWasmType], [SomeWasmType])
func_ty, FuncBody {[SomeWasmType]
WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
funcBody :: forall (w :: WasmType).
FuncBody w
-> WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
funcLocals :: forall (w :: WasmType). FuncBody w -> [SomeWasmType]
funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
funcLocals :: [SomeWasmType]
..}) = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Unique -> Int
getKey (forall a. Uniquable a => a -> Unique
getUnique SymName
sym) Int -> IntSet -> Bool
`IS.member` IntSet
def_syms) forall a b. (a -> b) -> a -> b
$ SymName -> WasmAsmM ()
asmTellDefSym SymName
sym
  Builder -> WasmAsmM ()
asmTellSectionHeader forall a b. (a -> b) -> a -> b
$ Builder
".text." forall a. Semigroup a => a -> a -> a
<> Builder
asm_sym
  Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
asm_sym forall a. Semigroup a => a -> a -> a
<> Builder
":"
  SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()
asmTellFuncType SymName
sym ([SomeWasmType], [SomeWasmType])
func_ty
  [SomeWasmType] -> WasmAsmM ()
asmTellLocals [SomeWasmType]
funcLocals
  forall a. WasmAsmM a -> WasmAsmM a
asmWithTab forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType) (a :: WasmType) (pre :: [WasmType])
       (post :: [WasmType]).
WasmTypeTag w
-> WasmControl (WasmStatements w) (WasmExpr w a) pre post
-> WasmAsmM ()
asmTellWasmControl WasmTypeTag w
ty_word WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
funcBody
  Builder -> WasmAsmM ()
asmTellTabLine Builder
"end_function"
  WasmAsmM ()
asmTellLF
  where
    asm_sym :: Builder
asm_sym = SymName -> Builder
asmFromSymName SymName
sym

asmTellGlobals :: WasmTypeTag w -> WasmAsmM ()
asmTellGlobals :: forall (w :: WasmType). WasmTypeTag w -> WasmAsmM ()
asmTellGlobals WasmTypeTag w
ty_word = do
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [GlobalReg]
supportedCmmGlobalRegs forall a b. (a -> b) -> a -> b
$ \GlobalReg
reg ->
    let (SymName
sym, SomeWasmType
ty) = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType).
WasmTypeTag w -> GlobalReg -> Maybe (SymName, SomeWasmType)
globalInfoFromCmmGlobalReg WasmTypeTag w
ty_word GlobalReg
reg
     in Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$
          Builder
".globaltype "
            forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
            forall a. Semigroup a => a -> a -> a
<> Builder
", "
            forall a. Semigroup a => a -> a -> a
<> SomeWasmType -> Builder
asmFromSomeWasmType SomeWasmType
ty
  WasmAsmM ()
asmTellLF

asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()
asmTellCtors :: forall (w :: WasmType). WasmTypeTag w -> [SymName] -> WasmAsmM ()
asmTellCtors WasmTypeTag w
_ [] = forall a. Monoid a => a
mempty
asmTellCtors WasmTypeTag w
ty_word [SymName]
syms = do
  Builder -> WasmAsmM ()
asmTellSectionHeader Builder
".init_array"
  Alignment -> WasmAsmM ()
asmTellAlign forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType). WasmTypeTag w -> Alignment
alignmentFromWordType WasmTypeTag w
ty_word
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [SymName]
syms forall a b. (a -> b) -> a -> b
$ \SymName
sym ->
    Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$
      ( case WasmTypeTag w
ty_word of
          WasmTypeTag w
TagI32 -> Builder
".int32 "
          WasmTypeTag w
TagI64 -> Builder
".int64 "
          WasmTypeTag w
_ -> forall a. HasCallStack => String -> a
panic String
"asmTellCtors: unreachable"
      )
        forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
  WasmAsmM ()
asmTellLF

asmTellBS :: ByteString -> WasmAsmM ()
asmTellBS :: ByteString -> WasmAsmM ()
asmTellBS ByteString
s = do
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".int8 " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (ByteString -> Int
BS.length ByteString
s)
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$
    Builder
".ascii \""
      forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7
        (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => ByteString -> doc
pprASCII ByteString
s)
      forall a. Semigroup a => a -> a -> a
<> Builder
"\""

asmTellVec :: [WasmAsmM ()] -> WasmAsmM ()
asmTellVec :: [WasmAsmM ()] -> WasmAsmM ()
asmTellVec [WasmAsmM ()]
xs = do
  Builder -> WasmAsmM ()
asmTellTabLine forall a b. (a -> b) -> a -> b
$ Builder
".int8 " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (forall (t :: * -> *) a. Foldable t => t a -> Int
length [WasmAsmM ()]
xs)
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [WasmAsmM ()]
xs

asmTellProducers :: WasmAsmM ()
asmTellProducers :: WasmAsmM ()
asmTellProducers = do
  Builder -> WasmAsmM ()
asmTellSectionHeader Builder
".custom_section.producers"
  [WasmAsmM ()] -> WasmAsmM ()
asmTellVec
    [ do
        ByteString -> WasmAsmM ()
asmTellBS ByteString
"processed-by"
        [WasmAsmM ()] -> WasmAsmM ()
asmTellVec
          [ do
              ByteString -> WasmAsmM ()
asmTellBS ByteString
"ghc"
              ByteString -> WasmAsmM ()
asmTellBS ByteString
"9.6"
          ]
    ]

asmTellTargetFeatures :: WasmAsmM ()
asmTellTargetFeatures :: WasmAsmM ()
asmTellTargetFeatures = do
  Builder -> WasmAsmM ()
asmTellSectionHeader Builder
".custom_section.target_features"
  [WasmAsmM ()] -> WasmAsmM ()
asmTellVec
    [ do
        Builder -> WasmAsmM ()
asmTellTabLine Builder
".int8 0x2b"
        ByteString -> WasmAsmM ()
asmTellBS ByteString
feature
      | ByteString
feature <-
          [ ByteString
"bulk-memory",
            ByteString
"mutable-globals",
            ByteString
"nontrapping-fptoint",
            ByteString
"reference-types",
            ByteString
"sign-ext"
          ]
    ]

asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()
asmTellEverything :: forall (w :: WasmType).
WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()
asmTellEverything WasmTypeTag w
ty_word WasmCodeGenState {Int
[SymName]
IntSet
Platform
SymMap ([SomeWasmType], [SomeWasmType])
SymMap (FuncBody w)
SymMap DataSection
UniqFM LocalReg LocalInfo
UniqSupply
wasmUniqSupply :: forall (w :: WasmType). WasmCodeGenState w -> UniqSupply
localRegsCount :: forall (w :: WasmType). WasmCodeGenState w -> Int
localRegs :: forall (w :: WasmType).
WasmCodeGenState w -> UniqFM LocalReg LocalInfo
ctors :: forall (w :: WasmType). WasmCodeGenState w -> [SymName]
dataSections :: forall (w :: WasmType). WasmCodeGenState w -> SymMap DataSection
funcBodies :: forall (w :: WasmType). WasmCodeGenState w -> SymMap (FuncBody w)
funcTypes :: forall (w :: WasmType).
WasmCodeGenState w -> SymMap ([SomeWasmType], [SomeWasmType])
defaultSyms :: forall (w :: WasmType). WasmCodeGenState w -> IntSet
wasmPlatform :: forall (w :: WasmType). WasmCodeGenState w -> Platform
wasmUniqSupply :: UniqSupply
localRegsCount :: Int
localRegs :: UniqFM LocalReg LocalInfo
ctors :: [SymName]
dataSections :: SymMap DataSection
funcBodies :: SymMap (FuncBody w)
funcTypes :: SymMap ([SomeWasmType], [SomeWasmType])
defaultSyms :: IntSet
wasmPlatform :: Platform
..} = do
  forall (w :: WasmType). WasmTypeTag w -> WasmAsmM ()
asmTellGlobals WasmTypeTag w
ty_word
  WasmAsmM ()
asm_functypes
  WasmAsmM ()
asm_funcs
  WasmAsmM ()
asm_data_secs
  WasmAsmM ()
asm_ctors
  WasmAsmM ()
asmTellProducers
  WasmAsmM ()
asmTellTargetFeatures
  where
    asm_functypes :: WasmAsmM ()
asm_functypes = do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
        (forall k a. Ord k => UniqMap k a -> [(k, a)]
detEltsUniqMap forall a b. (a -> b) -> a -> b
$ SymMap ([SomeWasmType], [SomeWasmType])
funcTypes forall k a b. UniqMap k a -> UniqMap k b -> UniqMap k a
`minusUniqMap` SymMap (FuncBody w)
funcBodies)
        (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()
asmTellFuncType)
      WasmAsmM ()
asmTellLF

    asm_funcs :: WasmAsmM ()
asm_funcs = do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
        (forall k a. Ord k => UniqMap k a -> [(k, a)]
detEltsUniqMap forall a b. (a -> b) -> a -> b
$ forall a b c k.
(a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c
intersectUniqMap_C (,) SymMap ([SomeWasmType], [SomeWasmType])
funcTypes SymMap (FuncBody w)
funcBodies)
        (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall (w :: WasmType).
WasmTypeTag w
-> IntSet
-> SymName
-> (([SomeWasmType], [SomeWasmType]), FuncBody w)
-> WasmAsmM ()
asmTellFunc WasmTypeTag w
ty_word IntSet
defaultSyms)
      WasmAsmM ()
asmTellLF

    asm_data_secs :: WasmAsmM ()
asm_data_secs = do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
        (forall k a. Ord k => UniqMap k a -> [(k, a)]
detEltsUniqMap SymMap DataSection
dataSections)
        (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (w :: WasmType).
WasmTypeTag w -> IntSet -> SymName -> DataSection -> WasmAsmM ()
asmTellDataSection WasmTypeTag w
ty_word IntSet
defaultSyms))
      WasmAsmM ()
asmTellLF

    asm_ctors :: WasmAsmM ()
asm_ctors = forall (w :: WasmType). WasmTypeTag w -> [SymName] -> WasmAsmM ()
asmTellCtors WasmTypeTag w
ty_word [SymName]
ctors