{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# 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)
newtype WasmAsmM a = WasmAsmM (Bool -> 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 Bool (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
doTailCall :: WasmAsmM Bool
doTailCall :: WasmAsmM Bool
doTailCall = forall a. (Bool -> Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Bool
do_tail_call Builder
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
do_tail_call
execWasmAsmM :: Bool -> WasmAsmM a -> Builder
execWasmAsmM :: forall a. Bool -> WasmAsmM a -> Builder
execWasmAsmM Bool
do_tail_call (WasmAsmM Bool -> Builder -> State Builder a
m) =
forall s a. State s a -> s -> s
execState (Bool -> Builder -> State Builder a
m Bool
do_tail_call forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty
asmWithTab :: WasmAsmM a -> WasmAsmM a
asmWithTab :: forall a. WasmAsmM a -> WasmAsmM a
asmWithTab (WasmAsmM Bool -> Builder -> State Builder a
m) =
forall a. (Bool -> Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Bool
do_tail_call Builder
t -> Bool -> Builder -> State Builder a
m Bool
do_tail_call forall a b. (a -> b) -> a -> b
$! Char -> Builder
char7 Char
'\t' forall a. Semigroup a => a -> a -> a
<> Builder
t
asmTellLine :: Builder -> WasmAsmM ()
asmTellLine :: Builder -> WasmAsmM ()
asmTellLine Builder
b = forall a. (Bool -> Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Bool
_ 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'
asmTellLF :: WasmAsmM ()
asmTellLF :: WasmAsmM ()
asmTellLF = forall a. (Bool -> Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Bool
_ 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'
asmTellTabLine :: Builder -> WasmAsmM ()
asmTellTabLine :: Builder -> WasmAsmM ()
asmTellTabLine Builder
b =
forall a. (Bool -> Builder -> State Builder a) -> WasmAsmM a
WasmAsmM forall a b. (a -> b) -> a -> b
$ \Bool
_ 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 Word8
i -> Builder
".int8 0x" forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
word8Hex Word8
i
DataI16 Word16
i -> Builder
".int16 0x" forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
word16Hex Word16
i
DataI32 Word32
i -> Builder
".int32 0x" forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
word32Hex Word32
i
DataI64 Word64
i -> Builder
".int64 0x" forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Hex Word64
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 ()
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"
WasmNeg 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
".neg"
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
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
"}"
WasmTailCall (WasmExpr forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e) -> do
Bool
do_tail_call <- WasmAsmM Bool
doTailCall
if
| Bool
do_tail_call,
WasmSymConst SymName
sym <- forall (pre :: [WasmType]). WasmInstr w pre (a : pre)
e ->
Builder -> WasmAsmM ()
asmTellLine forall a b. (a -> b) -> a -> b
$ Builder
"return_call " forall a. Semigroup a => a -> a -> a
<> SymName -> Builder
asmFromSymName SymName
sym
| Bool
do_tail_call ->
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
"return_call_indirect "
forall a. Semigroup a => a -> a -> a
<> [SomeWasmType] -> [SomeWasmType] -> Builder
asmFromFuncType
[]
[forall (t :: WasmType). WasmTypeTag t -> SomeWasmType
SomeWasmType WasmTypeTag w
ty_word]
| Bool
otherwise ->
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 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
Bool
do_tail_call <- WasmAsmM Bool
doTailCall
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
"tail-call" | Bool
do_tail_call]
forall a. Semigroup a => a -> a -> a
<> [ 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