{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

module GHC.CmmToAsm.Wasm.Types
  ( WasmType (..),
    WasmTypeTag (..),
    SomeWasmType (..),
    TypeList (..),
    someWasmTypesFromTypeList,
    WasmFunctionType (..),
    SymName (..),
    SymVisibility (..),
    SymKind (..),
    DataSectionKind (..),
    DataSectionContent (..),
    DataSection (..),
    GlobalInfo,
    LocalInfo,
    FuncBody (..),
    Signage (..),
    WasmInstr (..),
    WasmExpr (..),
    SomeWasmExpr (..),
    WasmStatements (..),
    WasmControl (..),
    BrTableInterval (..),
    wasmControlCast,
    WasmCodeGenState (..),
    initialWasmCodeGenState,
    WasmCodeGenM (..),
    wasmGetsM,
    wasmPlatformM,
    wasmWordTypeM,
    wasmWordCmmTypeM,
    wasmStateM,
    wasmModifyM,
    wasmExecM,
    wasmRunM,
    WasmAsmConfig (..),
    defaultWasmAsmConfig
  )
where

import Control.Applicative
import Data.ByteString (ByteString)
import Data.Coerce
import Data.Functor
import Data.Kind
import Data.String
import Data.Type.Equality
import Data.Word
import GHC.Cmm
import GHC.Data.FastString
import GHC.Float
import GHC.Platform
import GHC.Prelude
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Map
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSM
import GHC.Utils.Monad.State.Strict
import GHC.Utils.Outputable hiding ((<>))
import Unsafe.Coerce

-- | WebAssembly type of a WebAssembly value that WebAssembly code
-- could either expect on the evaluation stack or leave on the
-- evaluation stack.
data WasmType = I32 | I64 | F32 | F64

-- | Singleton type useful for programming with `WasmType` at the type
-- level.
data WasmTypeTag :: WasmType -> Type where
  TagI32 :: WasmTypeTag 'I32
  TagI64 :: WasmTypeTag 'I64
  TagF32 :: WasmTypeTag 'F32
  TagF64 :: WasmTypeTag 'F64

deriving instance Show (WasmTypeTag t)

instance TestEquality WasmTypeTag where
  WasmTypeTag a
TagI32 testEquality :: forall (a :: WasmType) (b :: WasmType).
WasmTypeTag a -> WasmTypeTag b -> Maybe (a :~: b)
`testEquality` WasmTypeTag b
TagI32 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  WasmTypeTag a
TagI64 `testEquality` WasmTypeTag b
TagI64 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  WasmTypeTag a
TagF32 `testEquality` WasmTypeTag b
TagF32 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  WasmTypeTag a
TagF64 `testEquality` WasmTypeTag b
TagF64 = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  WasmTypeTag a
_ `testEquality` WasmTypeTag b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

data SomeWasmType where
  SomeWasmType :: WasmTypeTag t -> SomeWasmType

instance Eq SomeWasmType where
  SomeWasmType WasmTypeTag t
ty0 == :: SomeWasmType -> SomeWasmType -> Bool
== SomeWasmType WasmTypeTag t
ty1
    | Just t :~: t
Refl <- WasmTypeTag t
ty0 WasmTypeTag t -> WasmTypeTag t -> Maybe (t :~: t)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: WasmType) (b :: WasmType).
WasmTypeTag a -> WasmTypeTag b -> Maybe (a :~: b)
`testEquality` WasmTypeTag t
ty1 = Bool
True
    | Bool
otherwise = Bool
False

-- | List of WebAssembly types used to describe the sequence of
-- WebAssembly values that a block of code may expect on the stack or
-- leave on the stack.
data TypeList :: [WasmType] -> Type where
  TypeListNil :: TypeList '[]
  TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts)

someWasmTypesFromTypeList :: TypeList ts -> [SomeWasmType]
someWasmTypesFromTypeList :: forall (ts :: [WasmType]). TypeList ts -> [SomeWasmType]
someWasmTypesFromTypeList TypeList ts
TypeListNil = []
someWasmTypesFromTypeList (WasmTypeTag t
ty `TypeListCons` TypeList ts
tys) =
  WasmTypeTag t -> SomeWasmType
forall (t :: WasmType). WasmTypeTag t -> SomeWasmType
SomeWasmType WasmTypeTag t
ty SomeWasmType -> [SomeWasmType] -> [SomeWasmType]
forall a. a -> [a] -> [a]
: TypeList ts -> [SomeWasmType]
forall (ts :: [WasmType]). TypeList ts -> [SomeWasmType]
someWasmTypesFromTypeList TypeList ts
tys

-- | The type of a WebAssembly function, loop, block, or conditional.
-- This type says what values the code expects to pop off the stack
-- and what values it promises to push.  The WebAssembly standard
-- requires that this type appear explicitly in the code.
data WasmFunctionType pre post = WasmFunctionType {forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList pre
ft_pops :: TypeList pre, forall (pre :: [WasmType]) (post :: [WasmType]).
WasmFunctionType pre post -> TypeList post
ft_pushes :: TypeList post}

-- | For simplicity, we record other metadata in 'WasmCodeGenState' by
-- need, instead of carrying them along with 'SymName'.
newtype SymName = SymName FastString
  deriving (SymName -> SymName -> Bool
(SymName -> SymName -> Bool)
-> (SymName -> SymName -> Bool) -> Eq SymName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymName -> SymName -> Bool
== :: SymName -> SymName -> Bool
$c/= :: SymName -> SymName -> Bool
/= :: SymName -> SymName -> Bool
Eq, String -> SymName
(String -> SymName) -> IsString SymName
forall a. (String -> a) -> IsString a
$cfromString :: String -> SymName
fromString :: String -> SymName
IsString, Int -> SymName -> ShowS
[SymName] -> ShowS
SymName -> String
(Int -> SymName -> ShowS)
-> (SymName -> String) -> ([SymName] -> ShowS) -> Show SymName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SymName -> ShowS
showsPrec :: Int -> SymName -> ShowS
$cshow :: SymName -> String
show :: SymName -> String
$cshowList :: [SymName] -> ShowS
showList :: [SymName] -> ShowS
Show, SymName -> Unique
(SymName -> Unique) -> Uniquable SymName
forall a. (a -> Unique) -> Uniquable a
$cgetUnique :: SymName -> Unique
getUnique :: SymName -> Unique
Uniquable) via FastString
  deriving (Eq SymName
Eq SymName =>
(SymName -> SymName -> Ordering)
-> (SymName -> SymName -> Bool)
-> (SymName -> SymName -> Bool)
-> (SymName -> SymName -> Bool)
-> (SymName -> SymName -> Bool)
-> (SymName -> SymName -> SymName)
-> (SymName -> SymName -> SymName)
-> Ord SymName
SymName -> SymName -> Bool
SymName -> SymName -> Ordering
SymName -> SymName -> SymName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SymName -> SymName -> Ordering
compare :: SymName -> SymName -> Ordering
$c< :: SymName -> SymName -> Bool
< :: SymName -> SymName -> Bool
$c<= :: SymName -> SymName -> Bool
<= :: SymName -> SymName -> Bool
$c> :: SymName -> SymName -> Bool
> :: SymName -> SymName -> Bool
$c>= :: SymName -> SymName -> Bool
>= :: SymName -> SymName -> Bool
$cmax :: SymName -> SymName -> SymName
max :: SymName -> SymName -> SymName
$cmin :: SymName -> SymName -> SymName
min :: SymName -> SymName -> SymName
Ord) via LexicalFastString

data SymVisibility
  = -- | Not defined in the current compilation unit.
    --
    -- @[ undefined binding=global vis=default ]@
    SymUndefined
  | -- | Defined, not visible to other compilation units.
    --
    -- @[ binding=local vis=default ]@
    SymStatic
  | -- | Defined, visible to other compilation units.
    --
    -- Adds @.globl@ directives in the output assembly. Also adds
    -- @.hidden@ when not generating PIC code, similar to
    -- -fvisibility=hidden in clang.
    --
    -- @[ binding=global vis=hidden ]@
    SymDefault

-- | Represents whether a symbol is a data symbol or a function
-- symbol. Unlike linkers for other targets, @wasm-ld@ does panic at
-- link-time if it finds symbol kind inconsistency between the
-- definition site and other use sites.
--
-- Currently we solely rely on 'isCFunctionLabel' to determine a
-- symbol's kind, but it does take extra effort to make it work. The
-- main source of inconsistency arises from hand-written Cmm sources,
-- where it's possible to refer to external entities like @xxx_info@
-- and @xxx_closure@ without explicit @import CLOSURE@ declarations.
-- The Cmm parser will implicitly assume those are foreign function
-- labels, and then this will break the WebAssembly backend. #22368
-- provides more context on this issue.
--
-- tl;dr for any GHC contributor that accidentally triggers @wasm-ld@
-- errors when hacking Cmm: whatever data symbols are used in new
-- code, just add the corresponding @import CLOSURE@ declarations at
-- the top of that Cmm file.
data SymKind = SymData | SymFunc
  deriving (SymKind -> SymKind -> Bool
(SymKind -> SymKind -> Bool)
-> (SymKind -> SymKind -> Bool) -> Eq SymKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymKind -> SymKind -> Bool
== :: SymKind -> SymKind -> Bool
$c/= :: SymKind -> SymKind -> Bool
/= :: SymKind -> SymKind -> Bool
Eq)

-- | WebAssembly doesn't really have proper read-only memory regions
-- yet. Neverthless we add the .rodata logic here, wasm-ld will
-- aggregate all .rodata sections into a single one, which adds
-- possibility for runtime checks later, either via a customized
-- runtime, or via code instrumentation. See
-- <https://github.com/llvm/llvm-project/blob/b296aed8ae239c20ebdd7969e978f8d2a3b9c178/lld/wasm/Writer.cpp#L856>
data DataSectionKind = SectionData | SectionROData

-- | Neither Cmm or Wasm type system takes integer signedness into
-- account, therefore we always round up a 'CmmLit' to the right width
-- and handle it as an untyped integer.
data DataSectionContent
  = DataI8 Word8
  | DataI16 Word16
  | DataI32 Word32
  | DataI64 Word64
  | DataF32 Float
  | DataF64 Double
  | DataSym SymName Int
  | DataSkip Int
  | DataASCII ByteString
  | DataIncBin FilePath Int

data DataSection = DataSection
  { DataSection -> DataSectionKind
dataSectionKind :: DataSectionKind,
    DataSection -> Alignment
dataSectionAlignment ::
      Alignment,
    DataSection -> [DataSectionContent]
dataSectionContents :: [DataSectionContent]
  }

-- | We need to remember the symbols. Determinism is achieved by
-- sorting symbols before writing the assembly.
type SymMap = UniqMap SymName

-- | No need to remember the symbols.
type SymSet = UniqueSet

type GlobalInfo = (SymName, SomeWasmType)

type LocalInfo = (Int, SomeWasmType)

data FuncBody w = FuncBody
  { forall (w :: WasmType). FuncBody w -> [SomeWasmType]
funcLocals :: [SomeWasmType],
    -- | Most are Cmm functions, but may also contain synthesized
    -- function of other types, sigh.
    forall (w :: WasmType).
FuncBody w
-> WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
  }

data Signage = Signed | Unsigned

-- | The @w@ type variable in the Wasm IR stands for "platform word
-- type", so 'TagI32' on wasm32, and 'TagI64' on wasm64. This way, we
-- can make the codegen logic work on both wasm32/wasm64 in a
-- type-safe manner.
data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where
  WasmComment :: String -> WasmInstr w pre pre
  WasmNop :: WasmInstr w pre pre
  WasmDrop :: WasmInstr w (t : pre) pre
  WasmUnreachable :: WasmInstr w pre post
  WasmConst :: WasmTypeTag t -> Integer -> WasmInstr w pre (t : pre)
  WasmSymConst :: SymName -> WasmInstr w pre (w : pre)
  WasmLoad ::
    WasmTypeTag t ->
    Maybe Int ->
    Signage ->
    Int ->
    AlignmentSpec ->
    WasmInstr w (w : pre) (t : pre)
  WasmStore ::
    WasmTypeTag t ->
    Maybe Int ->
    Int ->
    AlignmentSpec ->
    WasmInstr
      w
      (t : w : pre)
      pre
  WasmGlobalGet :: WasmTypeTag t -> SymName -> WasmInstr w pre (t : pre)
  WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmInstr w (t : pre) pre
  WasmLocalGet :: WasmTypeTag t -> Int -> WasmInstr w pre (t : pre)
  WasmLocalSet :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) pre
  WasmLocalTee :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) (t : pre)
  WasmCCall :: SymName -> WasmInstr w pre post
  WasmCCallIndirect ::
    TypeList arg_tys ->
    TypeList ret_tys ->
    WasmInstr
      w
      (w : pre)
      post
  WasmConcat ::
    WasmInstr w pre mid ->
    WasmInstr w mid post ->
    WasmInstr w pre post
  WasmReinterpret ::
    WasmTypeTag t0 ->
    WasmTypeTag t1 ->
    WasmInstr
      w
      (t0 : pre)
      (t1 : pre)
  WasmTruncSat ::
    Signage ->
    WasmTypeTag t0 ->
    WasmTypeTag t1 ->
    WasmInstr
      w
      (t0 : pre)
      (t1 : pre)
  WasmConvert ::
    Signage ->
    WasmTypeTag t0 ->
    WasmTypeTag t1 ->
    WasmInstr
      w
      (t0 : pre)
      (t1 : pre)
  WasmAdd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmSub :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmMul :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmDiv :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmRem :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmAnd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmOr :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmXor :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmEq :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmNe :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmLt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmGt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmLe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmGe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
  WasmShl :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmShr :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmI32Extend8S :: WasmInstr w ('I32 : pre) ('I32 : pre)
  WasmI32Extend16S :: WasmInstr w ('I32 : pre) ('I32 : pre)
  WasmI64Extend8S :: WasmInstr w ('I64 : pre) ('I64 : pre)
  WasmI64Extend16S :: WasmInstr w ('I64 : pre) ('I64 : pre)
  WasmI64Extend32S :: WasmInstr w ('I64 : pre) ('I64 : pre)
  WasmI64ExtendI32 :: Signage -> WasmInstr w ('I32 : pre) ('I64 : pre)
  WasmI32WrapI64 :: WasmInstr w ('I64 : pre) ('I32 : pre)
  WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)
  WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)
  WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
  WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
  WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
  WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre

newtype WasmExpr w t = WasmExpr (forall pre. WasmInstr w pre (t : pre))

data SomeWasmExpr w where
  SomeWasmExpr :: WasmTypeTag t -> WasmExpr w t -> SomeWasmExpr w

newtype WasmStatements w = WasmStatements (forall pre. WasmInstr w pre pre)

-- | Representation of WebAssembly control flow.
-- Normally written as
-- @
--   WasmControl s e pre post
-- @
-- Type parameter `s` is the type of (unspecified) statements.
-- It might be instantiated with an open Cmm block or with a sequence
-- of Wasm instructions.
-- Parameter `e` is the type of expressions.
-- Parameter `pre` represents the values that are expected on the
-- WebAssembly stack when the code runs, and `post` represents
-- the state of the stack on completion.
data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where
  WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t : stack)
  WasmBlock ::
    WasmFunctionType pre post ->
    WasmControl s e pre post ->
    WasmControl s e pre post
  WasmLoop ::
    WasmFunctionType pre post ->
    WasmControl s e pre post ->
    WasmControl s e pre post
  WasmIfTop ::
    WasmFunctionType pre post ->
    WasmControl s e pre post ->
    WasmControl s e pre post ->
    WasmControl s e ('I32 : pre) post
  WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked
  WasmFallthrough :: WasmControl s e dropped destination
  -- generates no code, but has the same type as a branch
  WasmBrTable ::
    e ->
    BrTableInterval -> -- for testing
    [Int] -> -- targets
    Int -> -- default target
    WasmControl s e dropped destination
  -- invariant: the table interval is contained
  -- within [0 .. pred (length targets)]

  -- Note [WasmTailCall]
  -- ~~~~~~~~~~~~~~~~~~~
  -- This represents the exit point of each CmmGraph: tail calling the
  -- destination in CmmCall. The STG stack may grow before the call,
  -- but it's always a tail call in the sense that the C call stack is
  -- guaranteed not to grow.
  --
  -- In the wasm backend, WasmTailCall is lowered to different
  -- assembly code given whether the wasm tail-call extension is
  -- enabled:
  --
  -- When tail-call is not enabled (which is the default as of today),
  -- a WasmTailCall is lowered to code that pushes the callee function
  -- pointer onto the value stack and returns immediately. The actual
  -- call is done by the trampoline in StgRun.
  --
  -- When tail-call is indeed enabled via passing -mtail-call in
  -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered
  -- to return_call/return_call_indirect, thus tail calling into its
  -- callee without returning to StgRun.
  WasmTailCall ::
    e ->
    WasmControl s e t1star t2star -- as per type system
  WasmActions ::
    s ->
    WasmControl s e stack stack -- basic block: one entry, one exit
  WasmSeq ::
    WasmControl s e pre mid ->
    WasmControl s e mid post ->
    WasmControl s e pre post

data BrTableInterval = BrTableInterval {BrTableInterval -> Integer
bti_lo :: Integer, BrTableInterval -> Integer
bti_count :: Integer}
  deriving (Int -> BrTableInterval -> ShowS
[BrTableInterval] -> ShowS
BrTableInterval -> String
(Int -> BrTableInterval -> ShowS)
-> (BrTableInterval -> String)
-> ([BrTableInterval] -> ShowS)
-> Show BrTableInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BrTableInterval -> ShowS
showsPrec :: Int -> BrTableInterval -> ShowS
$cshow :: BrTableInterval -> String
show :: BrTableInterval -> String
$cshowList :: [BrTableInterval] -> ShowS
showList :: [BrTableInterval] -> ShowS
Show)

instance Outputable BrTableInterval where
  ppr :: BrTableInterval -> SDoc
ppr BrTableInterval
range =
    SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
      [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat
        [Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer (BrTableInterval -> Integer
bti_lo BrTableInterval
range), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..", Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
hi]
    where
      hi :: Integer
hi = BrTableInterval -> Integer
bti_lo BrTableInterval
range Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ BrTableInterval -> Integer
bti_count BrTableInterval
range Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1

wasmControlCast :: WasmControl s e pre post -> WasmControl s e pre' post'
wasmControlCast :: forall s e (pre :: [WasmType]) (post :: [WasmType])
       (pre' :: [WasmType]) (post' :: [WasmType]).
WasmControl s e pre post -> WasmControl s e pre' post'
wasmControlCast = WasmControl s e pre post -> WasmControl s e pre' post'
forall a b. a -> b
unsafeCoerce

data WasmCodeGenState w = WasmCodeGenState
  { -- | Target platform
    forall (w :: WasmType). WasmCodeGenState w -> Platform
wasmPlatform :: Platform,
    -- | Defined symbols with 'SymDefault' visibility.
    forall (w :: WasmType). WasmCodeGenState w -> SymSet
defaultSyms :: SymSet,
    -- | Function types, defined or not. There may exist a function
    -- whose type is unknown (e.g. as a function pointer), in that
    -- case we fall back to () -> (), it's imperfect but works with
    -- wasm-ld.
    forall (w :: WasmType).
WasmCodeGenState w -> SymMap ([SomeWasmType], [SomeWasmType])
funcTypes :: SymMap ([SomeWasmType], [SomeWasmType]),
    -- | Defined function bodies.
    forall (w :: WasmType). WasmCodeGenState w -> SymMap (FuncBody w)
funcBodies :: SymMap (FuncBody w),
    -- | Defined data sections.
    forall (w :: WasmType). WasmCodeGenState w -> SymMap DataSection
dataSections :: SymMap DataSection,
    -- | ctors in the current compilation unit.
    forall (w :: WasmType). WasmCodeGenState w -> [SymName]
ctors :: [SymName],
    forall (w :: WasmType).
WasmCodeGenState w -> UniqFM LocalReg LocalInfo
localRegs ::
      UniqFM LocalReg LocalInfo,
    forall (w :: WasmType). WasmCodeGenState w -> Int
localRegsCount ::
      Int,
    forall (w :: WasmType). WasmCodeGenState w -> DUniqSupply
wasmDUniqSupply :: DUniqSupply
  }

initialWasmCodeGenState :: Platform -> DUniqSupply -> WasmCodeGenState w
initialWasmCodeGenState :: forall (w :: WasmType).
Platform -> DUniqSupply -> WasmCodeGenState w
initialWasmCodeGenState Platform
platform DUniqSupply
us =
  WasmCodeGenState
    { wasmPlatform :: Platform
wasmPlatform =
        Platform
platform,
      defaultSyms :: SymSet
defaultSyms = SymSet
emptyUniqueSet,
      funcTypes :: SymMap ([SomeWasmType], [SomeWasmType])
funcTypes = SymMap ([SomeWasmType], [SomeWasmType])
forall k a. UniqMap k a
emptyUniqMap,
      funcBodies :: SymMap (FuncBody w)
funcBodies =
        SymMap (FuncBody w)
forall k a. UniqMap k a
emptyUniqMap,
      dataSections :: SymMap DataSection
dataSections = SymMap DataSection
forall k a. UniqMap k a
emptyUniqMap,
      ctors :: [SymName]
ctors =
        [],
      localRegs :: UniqFM LocalReg LocalInfo
localRegs = UniqFM LocalReg LocalInfo
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM,
      localRegsCount :: Int
localRegsCount = Int
0,
      wasmDUniqSupply :: DUniqSupply
wasmDUniqSupply = DUniqSupply
us
    }

newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a)
  deriving newtype ((forall a b. (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b)
-> (forall a b. a -> WasmCodeGenM w b -> WasmCodeGenM w a)
-> Functor (WasmCodeGenM w)
forall a b. a -> WasmCodeGenM w b -> WasmCodeGenM w a
forall a b. (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
forall (w :: WasmType) a b.
a -> WasmCodeGenM w b -> WasmCodeGenM w a
forall (w :: WasmType) a b.
(a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (w :: WasmType) a b.
(a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
fmap :: forall a b. (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
$c<$ :: forall (w :: WasmType) a b.
a -> WasmCodeGenM w b -> WasmCodeGenM w a
<$ :: forall a b. a -> WasmCodeGenM w b -> WasmCodeGenM w a
Functor, Functor (WasmCodeGenM w)
Functor (WasmCodeGenM w) =>
(forall a. a -> WasmCodeGenM w a)
-> (forall a b.
    WasmCodeGenM w (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b)
-> (forall a b c.
    (a -> b -> c)
    -> WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w c)
-> (forall a b.
    WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b)
-> (forall a b.
    WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w a)
-> Applicative (WasmCodeGenM w)
forall a. a -> WasmCodeGenM w a
forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w a
forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
forall a b.
WasmCodeGenM w (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
forall a b c.
(a -> b -> c)
-> WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w c
forall (w :: WasmType). Functor (WasmCodeGenM w)
forall (w :: WasmType) a. a -> WasmCodeGenM w a
forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w a
forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
forall (w :: WasmType) a b.
WasmCodeGenM w (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
forall (w :: WasmType) a b c.
(a -> b -> c)
-> WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w 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
$cpure :: forall (w :: WasmType) a. a -> WasmCodeGenM w a
pure :: forall a. a -> WasmCodeGenM w a
$c<*> :: forall (w :: WasmType) a b.
WasmCodeGenM w (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
<*> :: forall a b.
WasmCodeGenM w (a -> b) -> WasmCodeGenM w a -> WasmCodeGenM w b
$cliftA2 :: forall (w :: WasmType) a b c.
(a -> b -> c)
-> WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w c
liftA2 :: forall a b c.
(a -> b -> c)
-> WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w c
$c*> :: forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
*> :: forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
$c<* :: forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w a
<* :: forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w a
Applicative, Applicative (WasmCodeGenM w)
Applicative (WasmCodeGenM w) =>
(forall a b.
 WasmCodeGenM w a -> (a -> WasmCodeGenM w b) -> WasmCodeGenM w b)
-> (forall a b.
    WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b)
-> (forall a. a -> WasmCodeGenM w a)
-> Monad (WasmCodeGenM w)
forall a. a -> WasmCodeGenM w a
forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
forall a b.
WasmCodeGenM w a -> (a -> WasmCodeGenM w b) -> WasmCodeGenM w b
forall (w :: WasmType). Applicative (WasmCodeGenM w)
forall (w :: WasmType) a. a -> WasmCodeGenM w a
forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
forall (w :: WasmType) a b.
WasmCodeGenM w a -> (a -> WasmCodeGenM w b) -> WasmCodeGenM w 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
$c>>= :: forall (w :: WasmType) a b.
WasmCodeGenM w a -> (a -> WasmCodeGenM w b) -> WasmCodeGenM w b
>>= :: forall a b.
WasmCodeGenM w a -> (a -> WasmCodeGenM w b) -> WasmCodeGenM w b
$c>> :: forall (w :: WasmType) a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
>> :: forall a b.
WasmCodeGenM w a -> WasmCodeGenM w b -> WasmCodeGenM w b
$creturn :: forall (w :: WasmType) a. a -> WasmCodeGenM w a
return :: forall a. a -> WasmCodeGenM w a
Monad)

instance MonadUniqDSM (WasmCodeGenM w) where
  liftUniqDSM :: forall a. UniqDSM a -> WasmCodeGenM w a
liftUniqDSM (UDSM DUniqSupply -> DUniqResult a
m) = (WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
forall (w :: WasmType) a.
(WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
wasmStateM ((WasmCodeGenState w -> (# a, WasmCodeGenState w #))
 -> WasmCodeGenM w a)
-> (WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
forall a b. (a -> b) -> a -> b
$ \WasmCodeGenState w
st ->
    let DUniqResult a
a DUniqSupply
us' = DUniqSupply -> DUniqResult a
m (WasmCodeGenState w -> DUniqSupply
forall (w :: WasmType). WasmCodeGenState w -> DUniqSupply
wasmDUniqSupply WasmCodeGenState w
st)
     in (# a
a, WasmCodeGenState w
st{wasmDUniqSupply=us'} #)

wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a
wasmGetsM :: forall (w :: WasmType) a.
(WasmCodeGenState w -> a) -> WasmCodeGenM w a
wasmGetsM = State (WasmCodeGenState w) a -> WasmCodeGenM w a
forall a b. Coercible a b => a -> b
coerce (State (WasmCodeGenState w) a -> WasmCodeGenM w a)
-> ((WasmCodeGenState w -> a) -> State (WasmCodeGenState w) a)
-> (WasmCodeGenState w -> a)
-> WasmCodeGenM w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WasmCodeGenState w -> a) -> State (WasmCodeGenState w) a
forall s a. (s -> a) -> State s a
gets

wasmPlatformM :: WasmCodeGenM w Platform
wasmPlatformM :: forall (w :: WasmType). WasmCodeGenM w Platform
wasmPlatformM = (WasmCodeGenState w -> Platform) -> WasmCodeGenM w Platform
forall (w :: WasmType) a.
(WasmCodeGenState w -> a) -> WasmCodeGenM w a
wasmGetsM WasmCodeGenState w -> Platform
forall (w :: WasmType). WasmCodeGenState w -> Platform
wasmPlatform

wasmWordTypeM :: WasmCodeGenM w (WasmTypeTag w)
wasmWordTypeM :: forall (w :: WasmType). WasmCodeGenM w (WasmTypeTag w)
wasmWordTypeM = (WasmCodeGenState w -> WasmTypeTag w)
-> WasmCodeGenM w (WasmTypeTag w)
forall (w :: WasmType) a.
(WasmCodeGenState w -> a) -> WasmCodeGenM w a
wasmGetsM ((WasmCodeGenState w -> WasmTypeTag w)
 -> WasmCodeGenM w (WasmTypeTag w))
-> (WasmCodeGenState w -> WasmTypeTag w)
-> WasmCodeGenM w (WasmTypeTag w)
forall a b. (a -> b) -> a -> b
$ \WasmCodeGenState w
s ->
  if Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ WasmCodeGenState w -> Platform
forall (w :: WasmType). WasmCodeGenState w -> Platform
wasmPlatform WasmCodeGenState w
s
    then WasmTypeTag 'I32 -> WasmTypeTag w
forall a b. a -> b
unsafeCoerce WasmTypeTag 'I32
TagI32
    else WasmTypeTag 'I64 -> WasmTypeTag w
forall a b. a -> b
unsafeCoerce WasmTypeTag 'I64
TagI64

wasmWordCmmTypeM :: WasmCodeGenM w CmmType
wasmWordCmmTypeM :: forall (w :: WasmType). WasmCodeGenM w CmmType
wasmWordCmmTypeM = (WasmCodeGenState w -> CmmType) -> WasmCodeGenM w CmmType
forall (w :: WasmType) a.
(WasmCodeGenState w -> a) -> WasmCodeGenM w a
wasmGetsM (Platform -> CmmType
bWord (Platform -> CmmType)
-> (WasmCodeGenState w -> Platform)
-> WasmCodeGenState w
-> CmmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WasmCodeGenState w -> Platform
forall (w :: WasmType). WasmCodeGenState w -> Platform
wasmPlatform)

wasmStateM ::
  (WasmCodeGenState w -> (# a, WasmCodeGenState w #)) ->
  WasmCodeGenM w a
wasmStateM :: forall (w :: WasmType) a.
(WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
wasmStateM = State (WasmCodeGenState w) a -> WasmCodeGenM w a
forall a b. Coercible a b => a -> b
coerce (State (WasmCodeGenState w) a -> WasmCodeGenM w a)
-> ((WasmCodeGenState w -> (# a, WasmCodeGenState w #))
    -> State (WasmCodeGenState w) a)
-> (WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> State (WasmCodeGenState w) a
forall s a. (s -> (# a, s #)) -> State s a
State

wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
wasmModifyM :: forall (w :: WasmType).
(WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
wasmModifyM = State (WasmCodeGenState w) () -> WasmCodeGenM w ()
forall a b. Coercible a b => a -> b
coerce (State (WasmCodeGenState w) () -> WasmCodeGenM w ())
-> ((WasmCodeGenState w -> WasmCodeGenState w)
    -> State (WasmCodeGenState w) ())
-> (WasmCodeGenState w -> WasmCodeGenState w)
-> WasmCodeGenM w ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WasmCodeGenState w -> WasmCodeGenState w)
-> State (WasmCodeGenState w) ()
forall s. (s -> s) -> State s ()
modify

wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM :: forall (w :: WasmType) a.
WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
wasmExecM (WasmCodeGenM State (WasmCodeGenState w) a
s) = State (WasmCodeGenState w) a
-> WasmCodeGenState w -> WasmCodeGenState w
forall s a. State s a -> s -> s
execState State (WasmCodeGenState w) a
s

wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w)
wasmRunM :: forall (w :: WasmType) a.
WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w)
wasmRunM (WasmCodeGenM State (WasmCodeGenState w) a
s) = State (WasmCodeGenState w) a
-> WasmCodeGenState w -> (a, WasmCodeGenState w)
forall s a. State s a -> s -> (a, s)
runState State (WasmCodeGenState w) a
s

instance MonadGetUnique (WasmCodeGenM w) where
  getUniqueM :: WasmCodeGenM w Unique
getUniqueM = (WasmCodeGenState w -> (# Unique, WasmCodeGenState w #))
-> WasmCodeGenM w Unique
forall (w :: WasmType) a.
(WasmCodeGenState w -> (# a, WasmCodeGenState w #))
-> WasmCodeGenM w a
wasmStateM ((WasmCodeGenState w -> (# Unique, WasmCodeGenState w #))
 -> WasmCodeGenM w Unique)
-> (WasmCodeGenState w -> (# Unique, WasmCodeGenState w #))
-> WasmCodeGenM w Unique
forall a b. (a -> b) -> a -> b
$
    \s :: WasmCodeGenState w
s@WasmCodeGenState {Int
[SymName]
UniqFM LocalReg LocalInfo
DUniqSupply
SymSet
SymMap ([SomeWasmType], [SomeWasmType])
SymMap (FuncBody w)
SymMap DataSection
Platform
wasmPlatform :: forall (w :: WasmType). WasmCodeGenState w -> Platform
defaultSyms :: forall (w :: WasmType). WasmCodeGenState w -> SymSet
funcTypes :: forall (w :: WasmType).
WasmCodeGenState w -> SymMap ([SomeWasmType], [SomeWasmType])
funcBodies :: forall (w :: WasmType). WasmCodeGenState w -> SymMap (FuncBody w)
dataSections :: forall (w :: WasmType). WasmCodeGenState w -> SymMap DataSection
ctors :: forall (w :: WasmType). WasmCodeGenState w -> [SymName]
localRegs :: forall (w :: WasmType).
WasmCodeGenState w -> UniqFM LocalReg LocalInfo
localRegsCount :: forall (w :: WasmType). WasmCodeGenState w -> Int
wasmDUniqSupply :: forall (w :: WasmType). WasmCodeGenState w -> DUniqSupply
wasmPlatform :: Platform
defaultSyms :: SymSet
funcTypes :: SymMap ([SomeWasmType], [SomeWasmType])
funcBodies :: SymMap (FuncBody w)
dataSections :: SymMap DataSection
ctors :: [SymName]
localRegs :: UniqFM LocalReg LocalInfo
localRegsCount :: Int
wasmDUniqSupply :: DUniqSupply
..} -> case DUniqSupply -> (Unique, DUniqSupply)
takeUniqueFromDSupply DUniqSupply
wasmDUniqSupply of
      (Unique
u, DUniqSupply
us) -> (# Unique
u, WasmCodeGenState w
s {wasmDUniqSupply = us} #)

data WasmAsmConfig = WasmAsmConfig
  {
    WasmAsmConfig -> Bool
pic, WasmAsmConfig -> Bool
tailcall :: Bool,
    -- | Data/function symbols with 'SymStatic' visibility (defined
    -- but not visible to other compilation units). When doing PIC
    -- codegen, private symbols must be emitted as @MBREL@/@TBREL@
    -- relocations in the code section. The public symbols, defined or
    -- elsewhere, are all emitted as @GOT@ relocations instead.
    WasmAsmConfig -> SymSet
mbrelSyms, WasmAsmConfig -> SymSet
tbrelSyms :: ~SymSet
  }

-- | The default 'WasmAsmConfig' must be extracted from the final
-- 'WasmCodeGenState'.
defaultWasmAsmConfig :: WasmCodeGenState w -> WasmAsmConfig
defaultWasmAsmConfig :: forall (w :: WasmType). WasmCodeGenState w -> WasmAsmConfig
defaultWasmAsmConfig WasmCodeGenState {Int
[SymName]
UniqFM LocalReg LocalInfo
DUniqSupply
SymSet
SymMap ([SomeWasmType], [SomeWasmType])
SymMap (FuncBody w)
SymMap DataSection
Platform
wasmPlatform :: forall (w :: WasmType). WasmCodeGenState w -> Platform
defaultSyms :: forall (w :: WasmType). WasmCodeGenState w -> SymSet
funcTypes :: forall (w :: WasmType).
WasmCodeGenState w -> SymMap ([SomeWasmType], [SomeWasmType])
funcBodies :: forall (w :: WasmType). WasmCodeGenState w -> SymMap (FuncBody w)
dataSections :: forall (w :: WasmType). WasmCodeGenState w -> SymMap DataSection
ctors :: forall (w :: WasmType). WasmCodeGenState w -> [SymName]
localRegs :: forall (w :: WasmType).
WasmCodeGenState w -> UniqFM LocalReg LocalInfo
localRegsCount :: forall (w :: WasmType). WasmCodeGenState w -> Int
wasmDUniqSupply :: forall (w :: WasmType). WasmCodeGenState w -> DUniqSupply
wasmPlatform :: Platform
defaultSyms :: SymSet
funcTypes :: SymMap ([SomeWasmType], [SomeWasmType])
funcBodies :: SymMap (FuncBody w)
dataSections :: SymMap DataSection
ctors :: [SymName]
localRegs :: UniqFM LocalReg LocalInfo
localRegsCount :: Int
wasmDUniqSupply :: DUniqSupply
..} =
  WasmAsmConfig
    { pic :: Bool
pic = Bool
False,
      tailcall :: Bool
tailcall = Bool
False,
      mbrelSyms :: SymSet
mbrelSyms = SymMap DataSection -> SymSet
forall a. SymMap a -> SymSet
mk_rel_syms SymMap DataSection
dataSections,
      tbrelSyms :: SymSet
tbrelSyms = SymMap (FuncBody w) -> SymSet
forall a. SymMap a -> SymSet
mk_rel_syms SymMap (FuncBody w)
funcBodies
    }
  where
    mk_rel_syms :: SymMap a -> SymSet
    mk_rel_syms :: forall a. SymMap a -> SymSet
mk_rel_syms =
      ((SymName, a) -> SymSet -> SymSet)
-> SymSet -> UniqMap SymName a -> SymSet
forall k a b. ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap
        ( \(SymName
sym, a
_) SymSet
acc ->
            if SymName -> Unique
forall a. Uniquable a => a -> Unique
getUnique SymName
sym Unique -> SymSet -> Bool
`memberUniqueSet` SymSet
defaultSyms
              then SymSet
acc
              else Unique -> SymSet -> SymSet
insertUniqueSet (SymName -> Unique
forall a. Uniquable a => a -> Unique
getUnique SymName
sym) SymSet
acc
        )
        SymSet
emptyUniqueSet