{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Handling of JavaScript foreign imports/exports
module GHC.HsToCore.Foreign.JavaScript
  ( dsJsImport
  , dsJsFExport
  , dsJsFExportDynamic
  )
where

import GHC.Prelude

import GHC.Platform

import GHC.Hs

import GHC.HsToCore.Monad
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Foreign.Prim
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Utils

import GHC.Core
import GHC.Core.Make
import GHC.Core.Utils
import GHC.Core.DataCon
import GHC.Core.Unfold.Make
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Multiplicity

import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Types.Literal
import GHC.Types.ForeignStubs
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Basic
import GHC.Types.Unique

import GHC.Unit.Module

import GHC.Tc.Utils.TcType

import GHC.Cmm.Expr
import GHC.Cmm.Utils

import GHC.JS.Ppr

import GHC.Driver.Session
import GHC.Driver.Config

import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names

import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Maybe

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding

dsJsFExport
  :: Id                 -- Either the exported Id,
                        -- or the foreign-export-dynamic constructor
  -> Coercion           -- Coercion between the Haskell type callable
                        -- from C, and its representation type
  -> CLabelString       -- The name to export to C land
  -> CCallConv
  -> Bool               -- True => foreign export dynamic
                        --         so invoke IO action that's hanging off
                        --         the first argument's stable pointer
  -> DsM ( CHeader      -- contents of Module_stub.h
         , CStub        -- contents of Module_stub.c
         , String       -- string describing type to pass to createAdj.
         , Int          -- size of args to stub function
         )

dsJsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsJsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
    let
       ty :: Type
ty                              = Pair Type -> Type
forall a. Pair a -> a
pSnd (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
       ([Id]
_tvs,Type
sans_foralls)             = Type -> ([Id], Type)
tcSplitForAllTyVars Type
ty
       ([Scaled Type]
fe_arg_tys', Type
orig_res_ty)      = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
       -- We must use tcSplits here, because we want to see
       -- the (IO t) in the corner of the type!
       fe_arg_tys :: [Scaled Type]
fe_arg_tys | Bool
isDyn     = [Scaled Type] -> [Scaled Type]
forall a. HasCallStack => [a] -> [a]
tail [Scaled Type]
fe_arg_tys'
                  | Bool
otherwise = [Scaled Type]
fe_arg_tys'

       -- Look at the result type of the exported function, orig_res_ty
       -- If it's IO t, return         (t, True)
       -- If it's plain t, return      (t, False)
       (Type
res_ty, Bool
is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
orig_res_ty of
                                -- The function already returns IO t
                                Just (TyCon
_ioTyCon, Type
res_ty) -> (Type
res_ty, Bool
True)
                                -- The function returns t
                                Maybe (TyCon, Type)
Nothing                 -> (Type
orig_res_ty, Bool
False)
    Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (CHeader, CStub, String, Arity)
-> DsM (CHeader, CStub, String, Arity)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CHeader, CStub, String, Arity)
 -> DsM (CHeader, CStub, String, Arity))
-> (CHeader, CStub, String, Arity)
-> DsM (CHeader, CStub, String, Arity)
forall a b. (a -> b) -> a -> b
$
      Platform
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportJSBits Platform
platform CLabelString
ext_name
                     (if Bool
isDyn then Maybe Id
forall a. Maybe a
Nothing else Id -> Maybe Id
forall a. a -> Maybe a
Just Id
fn_id)
                     ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
fe_arg_tys) Type
res_ty Bool
is_IO_res_ty CCallConv
cconv

mkFExportJSBits
  :: Platform
  -> FastString
  -> Maybe Id      -- Just==static, Nothing==dynamic
  -> [Type]
  -> Type
  -> Bool          -- True <=> returns an IO type
  -> CCallConv
  -> (CHeader,
      CStub,
      String,      -- the argument reps
      Int          -- total size of arguments
     )
mkFExportJSBits :: Platform
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportJSBits Platform
platform CLabelString
c_nm Maybe Id
maybe_target [Type]
arg_htys Type
res_hty Bool
is_IO_res_ty CCallConv
_cconv
 = (CHeader
header_bits, CStub
js_bits, String
type_string,
    [Arity] -> Arity
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Width -> Arity
widthInBytes (CmmType -> Width
typeWidth CmmType
rep) | (SDoc
_,SDoc
_,Type
_,CmmType
rep) <- [(SDoc, SDoc, Type, CmmType)]
arg_info] -- all the args
         -- NB. the calculation here isn't strictly speaking correct.
         -- We have a primitive Haskell type (eg. Int#, Double#), and
         -- we want to know the size, when passed on the C stack, of
         -- the associated C type (eg. HsInt, HsDouble).  We don't have
         -- this information to hand, but we know what GHC's conventions
         -- are for passing around the primitive Haskell types, so we
         -- use that instead.  I hope the two coincide --SDM
    )
 where
  -- list the arguments to the JS function
  arg_info :: [(SDoc,           -- arg name
                SDoc,           -- C type
                Type,           -- Haskell type
                CmmType)]       -- the CmmType
  arg_info :: [(SDoc, SDoc, Type, CmmType)]
arg_info  = [ let stg_type :: SDoc
stg_type = Type -> SDoc
showStgType Type
ty in
                (Arity -> SDoc -> SDoc
forall {doc} {a} {p}. (IsLine doc, Show a) => a -> p -> doc
arg_cname Arity
n SDoc
stg_type,
                 SDoc
stg_type,
                 Type
ty,
                 Platform -> Type -> CmmType
typeCmmType Platform
platform (Type -> Type
getPrimTyOf Type
ty))
              | (Type
ty,Arity
n) <- [Type] -> [Arity] -> [(Type, Arity)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_htys [Arity
1::Int ..] ]

  arg_cname :: a -> p -> doc
arg_cname a
n p
_stg_ty = String -> doc
forall doc. IsLine doc => String -> doc
text (Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:a -> String
forall a. Show a => a -> String
show a
n)

  type_string :: String
type_string = Platform -> Type -> Char
primTyDescChar Platform
platform Type
res_hty Char -> String -> String
forall a. a -> [a] -> [a]
: String
arg_type_string

  arg_type_string :: String
arg_type_string = [Platform -> Type -> Char
primTyDescChar Platform
platform Type
ty | (SDoc
_,SDoc
_,Type
ty,CmmType
_) <- [(SDoc, SDoc, Type, CmmType)]
arg_info]

  -- stuff to do with the return type of the JS function
  res_hty_is_unit :: Bool
res_hty_is_unit = Type
res_hty Type -> Type -> Bool
`eqType` Type
unitTy     -- Look through any newtypes

  unboxResType :: SDoc
unboxResType | Bool
res_hty_is_unit = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_getUnit"
               | Bool
otherwise       = Type -> SDoc
unpackHObj Type
res_hty

  header_bits :: CHeader
header_bits = CHeader -> (Id -> CHeader) -> Maybe Id -> CHeader
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CHeader
forall a. Monoid a => a
mempty Id -> CHeader
forall {a}. Uniquable a => a -> CHeader
idTag Maybe Id
maybe_target
  idTag :: a -> CHeader
idTag a
i = let (Char
tag, Arity
u) = Unique -> (Char, Arity)
unpkUnique (a -> Unique
forall a. Uniquable a => a -> Unique
getUnique a
i)
            in  SDoc -> CHeader
CHeader (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
tag SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Arity -> SDoc
forall doc. IsLine doc => Arity -> doc
int Arity
u)

  fun_args :: SDoc
fun_args
    | [(SDoc, SDoc, Type, CmmType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
arg_info = SDoc
forall doc. IsOutput doc => doc
empty -- text "void"
    | Bool
otherwise         = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma
                               ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((SDoc, SDoc, Type, CmmType) -> SDoc)
-> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
_ty,Type
_,CmmType
_) -> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
arg_info

  fun_proto :: SDoc
fun_proto
      = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"async" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"function" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
        (if Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target
         then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm
         else CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
        SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
fun_args

  fun_export :: SDoc
fun_export
     = case Maybe Id
maybe_target of
          Just Id
hs_fn | Just Module
m <- Name -> Maybe Module
nameModule_maybe (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
hs_fn) ->
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$foreignExport" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                        SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (
                          CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (UnitId -> String
unitIdString (Module -> UnitId
moduleUnitId Module
m)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (CLabelString -> String
unpackFS CLabelString
c_nm) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit String
type_string
                        ) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
          Maybe Id
_ -> SDoc
forall doc. IsOutput doc => doc
empty

  strlit :: String -> SDoc
strlit String
xs = Doc -> SDoc
docToSDoc (CLabelString -> Doc
pprStringLit (String -> CLabelString
mkFastString String
xs))

  -- the target which will form the root of what we ask rts_evalIO to run
  the_cfun :: SDoc
the_cfun
     = case Maybe Id
maybe_target of
          Maybe Id
Nothing    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$deRefStablePtr(the_stableptr)"
          Just Id
hs_fn -> Id -> SDoc
idClosureText Id
hs_fn

  -- the expression we give to rts_eval
  expr_to_run :: SDoc
  expr_to_run :: SDoc
expr_to_run
     = (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
-> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
forall {b} {d}. SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
the_cfun [(SDoc, SDoc, Type, CmmType)]
arg_info
       where
          appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
acc (SDoc
arg_cname, b
_, Type
arg_hty, d
_)
             = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_apply"
               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
acc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
mkHObj Type
arg_hty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
arg_cname)

  -- finally, the whole darn thing
  js_bits :: CStub
js_bits = CStub { getCStub :: SDoc
getCStub        = SDoc
js_sdoc
                  , getInitializers :: [CLabel]
getInitializers = [CLabel]
forall a. Monoid a => a
mempty
                  , getFinalizers :: [CLabel]
getFinalizers   = [CLabel]
forall a. Monoid a => a
mempty
                  }
       where js_sdoc :: SDoc
js_sdoc = SDoc
forall doc. IsLine doc => doc
space
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_proto
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                 [ SDoc
forall doc. IsLine doc => doc
lbrace
                 ,   String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"return"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"await"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_eval"
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ((if Bool
is_IO_res_ty
                                 then SDoc
expr_to_run
                                 else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_toIO" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
expr_to_run)
                                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
unboxResType)
                     SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
                 , SDoc
forall doc. IsLine doc => doc
rbrace
                 ]
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_export

idClosureText :: Id -> SDoc
idClosureText :: Id -> SDoc
idClosureText Id
i
  | Id -> Bool
isExportedId Id
i
  , Name
name <- Id -> Name
forall a. NamedThing a => a -> Name
getName Id
i
  , Just Module
m <- Name -> Maybe Module
nameModule_maybe Name
name
  = let str :: String
str = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (Module -> Name -> SDoc
pprFullName Module
m (Name -> Name
localiseName Name
name))
    in String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> String
zEncodeString String
str)
  | Bool
otherwise
  = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"idClosureText: unknown module"

-- | Desugaring of JavaScript foreign imports
dsJsImport
  :: Id
  -> Coercion
  -> CImportSpec
  -> CCallConv
  -> Safety
  -> Maybe Header
  -> DsM ([Binding], CHeader, CStub)
dsJsImport :: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsImport Id
id Coercion
co (CLabel CLabelString
cid) CCallConv
cconv Safety
_ Maybe Header
_ = do
   let ty :: Type
ty = Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
       fod :: FunctionOrData
fod = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
dropForAlls Type
ty) of
             Just TyCon
tycon
              | TyCon -> Unique
tyConUnique TyCon
tycon Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
                 FunctionOrData
IsFunction
             Maybe TyCon
_ -> FunctionOrData
IsData
   (Maybe Type
_resTy, CoreExpr -> CoreExpr
foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
ty
--   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
   let rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
foRhs (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
cid Maybe Arity
stdcall_info FunctionOrData
fod))
       rhs' :: CoreExpr
rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
       stdcall_info :: Maybe Arity
stdcall_info = CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info CCallConv
cconv Type
ty

   ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
id, CoreExpr
rhs')], CHeader
forall a. Monoid a => a
mempty, CStub
forall a. Monoid a => a
mempty)

dsJsImport Id
id Coercion
co (CFunction CCallTarget
target) cconv :: CCallConv
cconv@CCallConv
PrimCallConv Safety
safety Maybe Header
_
  = Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
dsPrimCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety))
dsJsImport Id
id Coercion
co (CFunction CCallTarget
target) CCallConv
cconv Safety
safety Maybe Header
mHeader
  = Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
mHeader
dsJsImport Id
id Coercion
co CImportSpec
CWrapper CCallConv
cconv Safety
_ Maybe Header
_
  = Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic Id
id Coercion
co CCallConv
cconv

-- fixme work in progress
-- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic?
-- Lot of duplication
dsJsFExportDynamic :: Id
                 -> Coercion
                 -> CCallConv
                 -> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsJsFExportDynamic Id
id Coercion
co0 CCallConv
cconv = do
    let
      ty :: Type
ty                            = Pair Type -> Type
forall a. Pair a -> a
pFst (Coercion -> Pair Type
coercionKind Coercion
co0)
      ([Id]
tvs,Type
sans_foralls)            = Type -> ([Id], Type)
tcSplitForAllTyVars Type
ty
      ([Scaled Type
arg_mult Type
arg_ty], Type
fn_res_ty)  = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
      (TyCon
io_tc, Type
res_ty)               = String -> Maybe (TyCon, Type) -> (TyCon, Type)
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"dsJsFExportDynamic: IO type expected"
                                        -- Must have an IO type; hence Just
                                        (Maybe (TyCon, Type) -> (TyCon, Type))
-> Maybe (TyCon, Type) -> (TyCon, Type)
forall a b. (a -> b) -> a -> b
$ Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
    Module
mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let fe_nm :: CLabelString
fe_nm = String -> CLabelString
mkFastString (String -> CLabelString) -> String -> CLabelString
forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
            (String
"h$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
moduleStableString Module
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
toJsName Id
id)
        -- Construct the label based on the passed id, don't use names
        -- depending on Unique. See #13807 and Note [Unique Determinism].
    Id
cback <- Type -> Type -> DsM Id
newSysLocalDs Type
arg_mult Type
arg_ty
    Id
newStablePtrId <- Name -> DsM Id
dsLookupGlobalId Name
newStablePtrName
    TyCon
stable_ptr_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
    let
        stable_ptr_ty :: Type
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
        export_ty :: Type
export_ty     = (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
    Id
bindIOId <- Name -> DsM Id
dsLookupGlobalId Name
bindIOName
    Id
stbl_value <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
stable_ptr_ty
    (CHeader
h_code, CStub
c_code, String
typestring, Arity
args_size) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsJsFExport Id
id (Type -> Coercion
mkRepReflCo Type
export_ty) CLabelString
fe_nm CCallConv
cconv Bool
True
    let
         {-
          The arguments to the external function which will
          create a little bit of (template) code on the fly
          for allowing the (stable pointed) Haskell closure
          to be entered using an external calling convention
          (stdcall, ccall).
         -}
        adj_args :: [CoreExpr]
adj_args      = [ Platform -> Integer -> CoreExpr
forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger (CCallConv -> Arity
ccallConvToInt CCallConv
cconv))
                        , Id -> CoreExpr
forall b. Id -> Expr b
Var Id
stbl_value
                        , Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm Maybe Arity
mb_sz_args FunctionOrData
IsFunction)
                        , Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
                        ]
          -- name of external entry point providing these services.
          -- (probably in the RTS.)
        adjustor :: CLabelString
adjustor   = String -> CLabelString
fsLit String
"createAdjustor"

          -- Determine the number of bytes of arguments to the stub function,
          -- so that we can attach the '@N' suffix to its label if it is a
          -- stdcall on Windows.
        mb_sz_args :: Maybe Arity
mb_sz_args = case CCallConv
cconv of
                        CCallConv
StdCallConv -> Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
args_size
                        CCallConv
_           -> Maybe Arity
forall a. Maybe a
Nothing

    CoreExpr
ccall_adj <- CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall CLabelString
adjustor [CoreExpr]
adj_args Safety
PlayRisky (TyCon -> [Type] -> Type
mkTyConApp TyCon
io_tc [Type
res_ty])
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

    let io_app :: CoreExpr
io_app = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
cback                   (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                 CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindIOId)
                        [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
stable_ptr_ty
                        , Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty
                        , CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
newStablePtrId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cback ]
                        , Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
stbl_value CoreExpr
ccall_adj
                        ]

        fed :: Binding
fed = (Id
id Id -> Activation -> Id
`setInlineActivation` Activation
NeverActive, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
               -- Never inline the f.e.d. function, because the litlit
               -- might not be in scope in other modules.

    ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding
fed], CHeader
h_code, CStub
c_code)

toJsName :: Id -> String
toJsName :: Id -> String
toJsName Id
i = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> SDoc
pprCode (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Name
idName Id
i)))

dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsJsCall :: Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsJsCall Id
fn_id Coercion
co (CCall (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
_mDeclHeader = do
    let
        ty :: Type
ty                   = Pair Type -> Type
forall a. Pair a -> a
pFst (Pair Type -> Type) -> Pair Type -> Type
forall a b. (a -> b) -> a -> b
$ Coercion -> Pair Type
coercionKind Coercion
co
        ([TyVarBinder]
tv_bndrs, Type
rho)      = Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders Type
ty
        ([Scaled Type]
arg_tys, Type
io_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
rho

    [Id]
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys  -- no FFI levity-polymorphism
    ([CoreExpr]
val_args, [CoreExpr -> CoreExpr]
arg_wrappers) <- (CoreExpr
 -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr))
-> [CoreExpr]
-> IOEnv
     (Env DsGblEnv DsLclEnv) ([CoreExpr], [CoreExpr -> CoreExpr])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args)

    let
        work_arg_ids :: [Id]
work_arg_ids  = [Id
v | Var Id
v <- [CoreExpr]
val_args] -- All guaranteed to be vars

    (Type
ccall_result_ty, CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult Type
io_res_ty

    Unique
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    Unique
work_uniq  <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique

    SimpleOpts
simpl_opts <- DynFlags -> SimpleOpts
initSimpleOpts (DynFlags -> SimpleOpts)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) SimpleOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let
        -- Build the worker
        fcall :: ForeignCall
fcall         = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)
        worker_ty :: Type
worker_ty     = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTysMany ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
        tvs :: [Id]
tvs           = (TyVarBinder -> Id) -> [TyVarBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
        the_ccall_app :: CoreExpr
the_ccall_app = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
fcall [CoreExpr]
val_args Type
ccall_result_ty
        work_rhs :: CoreExpr
work_rhs      = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_arg_ids CoreExpr
the_ccall_app)
        work_id :: Id
work_id       = CLabelString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
ManyTy Type
worker_ty

        -- Build the wrapper
        work_app :: CoreExpr
work_app     = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
        wrapper_body :: CoreExpr
wrapper_body = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
        wrap_rhs :: CoreExpr
wrap_rhs     = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
        wrap_rhs' :: CoreExpr
wrap_rhs'    = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
        fn_id_w_inl :: Id
fn_id_w_inl  = Id
fn_id
                       Id -> Unfolding -> Id
`setIdUnfolding`
                       SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
simpl_opts UnfoldingSource
VanillaSrc
                                                  ([Id] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
args)  CoreExpr
wrap_rhs'

    ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
work_id, CoreExpr
work_rhs), (Id
fn_id_w_inl, CoreExpr
wrap_rhs')], CHeader
forall a. Monoid a => a
mempty, CStub
forall a. Monoid a => a
mempty)


mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_mk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)

unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"h$rts_get" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)

showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Type -> String
showFFIType Type
t)

showFFIType :: Type -> String
showFFIType :: Type -> String
showFFIType Type
t = Name -> String
forall a. NamedThing a => a -> String
getOccString (TyCon -> Name
forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
t))

typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
  -- UnaryRep rep_ty <- repType ty
  | Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty) -- rep_ty
  = TyCon
tc
  | Bool
otherwise
  = String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeTyCon" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)


{-
  We unbox arguments for JS calls a bit different from native code:
    - Bool is marshalled to true/false, not 0/1
    - All int types are narrowed, since JS floats have a greater range than Int32
 -}

unboxJsArg :: CoreExpr                  -- The supplied argument
           -> DsM (CoreExpr,              -- To pass as the actual argument
                   CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
                  )
unboxJsArg :: CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg CoreExpr
arg
  -- Primtive types: nothing to unbox
  | Type -> Bool
isPrimitiveType Type
arg_ty
  = (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg, \CoreExpr
body -> CoreExpr
body)

  -- Recursive newtypes
  | Just (Coercion
co, Type
_rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
arg_ty
  = CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg ((() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
arg Coercion
co)

  -- Booleans, do not convert to 0/1, only force them
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
    TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
  = (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
              \ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
boolTy) ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])

  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
    TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
  = (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
              \ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
arg_ty) ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
  -- Data types with a single constructor, which has a single, primitive-typed arg
  -- This deals with Int, Float etc; also Ptr, ForeignPtr
  | Bool
is_product_type Bool -> Bool -> Bool
&& Arity
data_con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
    = do Id
case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
         Id
prim_arg <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty1)
         (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
prim_arg,
               \ CoreExpr
body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Id
prim_arg] CoreExpr
body]
              )

  -- Byte-arrays, both mutable and otherwise; hack warning
  -- We're looking for values of type ByteArray, MutableByteArray
  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
  | Bool
is_product_type Bool -> Bool -> Bool
&&
    Arity
data_con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
3 Bool -> Bool -> Bool
&&
    Maybe TyCon -> Bool
forall a. Maybe a -> Bool
isJust Maybe TyCon
maybe_arg3_tycon Bool -> Bool -> Bool
&&
    (TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
==  TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
     TyCon
arg3_tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
==  TyCon
mutableByteArrayPrimTyCon)
  = do Id
case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
       vars :: [Id]
vars@[Id
_l_var, Id
_r_var, Id
arr_cts_var] <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
data_con_arg_tys
       (CoreExpr, CoreExpr -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arr_cts_var,
               \ CoreExpr
body -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Id]
vars CoreExpr
body]
              )

  | Bool
otherwise
  = do SrcSpan
l <- DsM SrcSpan
getSrcSpanDs
       String
-> SDoc
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unboxJsArg: " (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
  where
    arg_ty :: Type
arg_ty                                      = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
arg
    maybe_product_type :: Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type                          = Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
arg_ty
    is_product_type :: Bool
is_product_type                             = Maybe (TyCon, [Type], DataCon, [Scaled Type]) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
    Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type]
data_con_arg_tys)     = Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
    data_con_arity :: Arity
data_con_arity                              = DataCon -> Arity
dataConSourceArity DataCon
data_con
    (Scaled Type
data_con_arg_ty1 : [Scaled Type]
_)                      = [Scaled Type]
data_con_arg_tys

    (Scaled Type
_ : Scaled Type
_ : Scaled Type
data_con_arg_ty3 : [Scaled Type]
_) = [Scaled Type]
data_con_arg_tys
    maybe_arg3_tycon :: Maybe TyCon
maybe_arg3_tycon               = Type -> Maybe TyCon
tyConAppTyCon_maybe (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty3)
    Just TyCon
arg3_tycon                = Maybe TyCon
maybe_arg3_tycon


boxJsResult :: Type
            -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult Type
result_ty
  | Type -> Bool
isRuntimeRepKindedTy Type
result_ty = String -> DsM (Type, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> a
panic String
"boxJsResult: runtime rep ty" -- fixme
-- Takes the result of the user-level ccall:
--      either (IO t),
--      or maybe just t for an side-effect-free call
-- Returns a wrapper for the primitive ccall itself, along with the
-- type of the result of the primitive ccall.  This result type
-- will be of the form
--      State# RealWorld -> (# State# RealWorld, t' #)
-- where t' is the unwrapped form of t.  If t is simply (), then
-- the result type will be
--      State# RealWorld -> (# State# RealWorld #)

boxJsResult Type
result_ty
  | Just (TyCon
io_tycon, Type
io_res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
result_ty
        -- isIOType_maybe handles the case where the type is a
        -- simple wrapping of IO.  E.g.
        --      newtype Wrap a = W (IO a)
        -- No coercion necessary because its a non-recursive newtype
        -- (If we wanted to handle a *recursive* newtype too, we'd need
        -- another case, and a coercion.)
        -- The result is IO t, so wrap the result in an IO constructor
  = do  { (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
io_res_ty
        ; let return_result :: CoreExpr -> CoreExpr -> CoreExpr
return_result CoreExpr
state CoreExpr
ans
                = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
state, CoreExpr
ans]

        ; (Type
ccall_res_ty, CoreAlt
the_alt) <- (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Maybe Type, CoreExpr -> CoreExpr)
res

        ; Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
        ; let io_data_con :: DataCon
io_data_con = [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
io_tycon)
              toIOCon :: Id
toIOCon     = DataCon -> Id
dataConWrapId DataCon
io_data_con

              wrap :: CoreExpr -> CoreExpr
wrap CoreExpr
the_call =
                              CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
toIOCon)
                                     [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
io_res_ty,
                                       Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
state_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                       CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id))
                                             (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
                                             (CoreAlt -> Type
coreAltType CoreAlt
the_alt)
                                             [CoreAlt
the_alt]
                                     ]

        ; (Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap) }

boxJsResult Type
result_ty
  = do -- It isn't IO, so do unsafePerformIO
       -- It's not conveniently available, so we inline it
       (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
       (Type
ccall_res_ty, CoreAlt
the_alt) <- (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
forall {p} {p}. p -> p -> p
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
       let
           wrap :: CoreExpr -> CoreExpr
wrap = \ CoreExpr
the_call -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
realWorldPrimId))
                                           (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
                                           (CoreAlt -> Type
coreAltType CoreAlt
the_alt)
                                           [CoreAlt
the_alt]
       (Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy (() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
  where
    return_result :: p -> p -> p
return_result p
_ p
ans = p
ans

mk_alt :: (Expr Var -> Expr Var -> Expr Var)
       -> (Maybe Type, Expr Var -> Expr Var)
       -> DsM (Type, CoreAlt)
mk_alt :: (CoreExpr -> CoreExpr -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, CoreAlt)
mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Maybe Type
Nothing, CoreExpr -> CoreExpr
wrap_result)
  = do -- The ccall returns ()
       Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
       let
             the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
                                     (CoreExpr -> CoreExpr
wrap_result (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ String -> CoreExpr
forall a. HasCallStack => String -> a
panic String
"jsBoxResult")
             ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
             the_alt :: CoreAlt
the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
1)) [Id
state_id] CoreExpr
the_rhs
       (Type, CoreAlt) -> DsM (Type, CoreAlt)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)

mk_alt CoreExpr -> CoreExpr -> CoreExpr
return_result (Just Type
prim_res_ty, CoreExpr -> CoreExpr
wrap_result)
                -- The ccall returns a non-() value
  | Type -> Bool
isUnboxedTupleType Type
prim_res_ty = do
    let
        Just [Type]
ls = ([Type] -> [Type]) -> Maybe [Type] -> Maybe [Type]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> [Type]
dropRuntimeRepArgs (Type -> Maybe [Type]
tyConAppArgs_maybe Type
prim_res_ty)
        arity :: Arity
arity = Arity
1 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
ls
    [Id]
args_ids <- (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy) [Type]
ls
    Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
    let
        result_tup :: CoreExpr
result_tup = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
args_ids)
        the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
                                (CoreExpr -> CoreExpr
wrap_result CoreExpr
result_tup)
        ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed (Type
realWorldStatePrimTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ls)
        the_alt :: CoreAlt
the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
arity))
                           (Id
state_id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
args_ids)
                          CoreExpr
the_rhs
    (Type, CoreAlt) -> DsM (Type, CoreAlt)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)

  | Bool
otherwise = do
    Id
result_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
prim_res_ty
    Id
state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
    let
        the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
state_id)
                                (CoreExpr -> CoreExpr
wrap_result (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
result_id))
        ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
        the_alt :: CoreAlt
the_alt      = AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
2)) [Id
state_id, Id
result_id] CoreExpr
the_rhs
    (Type, CoreAlt) -> DsM (Type, CoreAlt)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, CoreAlt
the_alt)

fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info CCallConv
_other_conv Type
_ = Maybe Arity
forall a. Maybe a
Nothing


jsResultWrapper
  :: Type
  -> DsM ( Maybe Type           -- Type of the expected result, if any
         , CoreExpr -> CoreExpr -- Wrapper for the result
         )
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
jsResultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
  | Type -> Bool
isRuntimeRepKindedTy Type
result_ty = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
forall a. Maybe a
Nothing, CoreExpr -> CoreExpr
forall a. a -> a
id) -- fixme this seems like a hack
  -- Base case 1a: unboxed tuples
  | Just (TyCon
tc, [Type]
args) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
  , TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc {- && False -} = do
    let args' :: [Type]
args' = [Type] -> [Type]
dropRuntimeRepArgs [Type]
args
    ([Maybe Type]
tys, [CoreExpr -> CoreExpr]
wrappers) <- [(Maybe Type, CoreExpr -> CoreExpr)]
-> ([Maybe Type], [CoreExpr -> CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Type, CoreExpr -> CoreExpr)]
 -> ([Maybe Type], [CoreExpr -> CoreExpr]))
-> IOEnv
     (Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
-> IOEnv
     (Env DsGblEnv DsLclEnv) ([Maybe Type], [CoreExpr -> CoreExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> DsM (Maybe Type, CoreExpr -> CoreExpr))
-> [Type]
-> IOEnv
     (Env DsGblEnv DsLclEnv) [(Maybe Type, CoreExpr -> CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper [Type]
args'
    [Maybe Id]
matched <- (Maybe Type -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Id))
-> [Maybe Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Maybe Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> DsM Id)
-> Maybe Type -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe Id)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy)) [Maybe Type]
tys
    let tys' :: [Type]
tys'    = [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
tys
        -- arity   = length args'
        -- resCon  = tupleDataCon Unboxed (length args)
        err :: a
err     = String -> a
forall a. HasCallStack => String -> a
panic String
"jsResultWrapper: used Id with result type Nothing"
        resWrap :: CoreExpr
        resWrap :: CoreExpr
resWrap = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple (((CoreExpr -> CoreExpr) -> Maybe Id -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> [Maybe Id] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\CoreExpr -> CoreExpr
w -> CoreExpr -> CoreExpr
w (CoreExpr -> CoreExpr)
-> (Maybe Id -> CoreExpr) -> Maybe Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr
forall b. Id -> Expr b
Var (Id -> CoreExpr) -> (Maybe Id -> Id) -> Maybe Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Maybe Id -> Id
forall a. a -> Maybe a -> a
fromMaybe Id
forall {a}. a
err) [CoreExpr -> CoreExpr]
wrappers [Maybe Id]
matched)
    (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Type, CoreExpr -> CoreExpr)
 -> DsM (Maybe Type, CoreExpr -> CoreExpr))
-> (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$
      if [Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys'
        then (Maybe Type
forall a. Maybe a
Nothing, \CoreExpr
_ -> CoreExpr
resWrap)
        else let innerArity :: Arity
innerArity = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys'
                 innerTy :: Type
innerTy    = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys'
                 innerCon :: DataCon
innerCon   = Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
innerArity
                 inner :: CoreExpr -> CoreExpr
                 inner :: CoreExpr -> CoreExpr
inner CoreExpr
e    = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
e (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
                                         [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
innerCon)
                                              ([Maybe Id] -> [Id]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Id]
matched)
                                              CoreExpr
resWrap
                                         ]
             in (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
innerTy, CoreExpr -> CoreExpr
inner)

  -- Base case 1b: primitive types
  | Type -> Bool
isPrimitiveType Type
result_ty
  = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)
  -- Base case 1c: boxed tuples
  -- fixme: levity args?
  | Just (TyCon
tc, [Type]
args) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty
  , TyCon -> Bool
isBoxedTupleTyCon TyCon
tc = do
      let args' :: [Type]
args'   = [Type] -> [Type]
dropRuntimeRepArgs [Type]
args
          innerTy :: Type
innerTy = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
args'
      (Maybe Type
inner_res, CoreExpr -> CoreExpr
w) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
innerTy
      [Id]
matched <- (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy) [Type]
args'
      let inner :: CoreExpr -> CoreExpr
inner CoreExpr
e = CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (CoreExpr -> CoreExpr
w CoreExpr
e) (Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
                               [ AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed ([Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args')))
                                     [Id]
matched
                                     ([CoreExpr] -> CoreExpr
mkCoreTup ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
Var [Id]
matched))
                                -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
                               ]
      (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
inner_res, CoreExpr -> CoreExpr
inner)

  -- Base case 2: the unit type ()
  | Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
  = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
forall a. Maybe a
Nothing, \CoreExpr
_ -> Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unitDataConId)

  -- Base case 3: the boolean type
  | Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey = do
--    result_id <- newSysLocalDs boolTy
    Unique
ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    let forceBool :: CoreExpr -> CoreExpr
forceBool CoreExpr
e = Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
ccall_uniq String
"$r = !(!$1)" [CoreExpr
e] Type
boolTy
    (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return
     (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
intPrimTy, \CoreExpr
e -> CoreExpr -> CoreExpr
forceBool CoreExpr
e)

  -- Base case 4: the any type
  |  Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
  = (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)

  -- Newtypes
  | Just (Coercion
co, Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
result_ty
  = do (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rep_ty
       (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
mkCastDs (CoreExpr -> CoreExpr
wrapper CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co))

  -- The type might contain foralls (eg. for dummy type arguments,
  -- referring to 'Ptr a' is legal).
  | Just (Id
tyvar, Type
rest) <- Type -> Maybe (Id, Type)
splitForAllTyCoVar_maybe Type
result_ty
  = do (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rest
       (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
tyvar (CoreExpr -> CoreExpr
wrapper CoreExpr
e))

  -- Data types with a single constructor, which has a single arg
  -- This includes types like Ptr and ForeignPtr
  | Just (TyCon
_tycon, [Type]
tycon_arg_tys, DataCon
data_con, [Scaled Type]
data_con_arg_tys) <- Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
result_ty,
    DataCon -> Arity
dataConSourceArity DataCon
data_con Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
  = do let (Scaled Type
unwrapped_res_ty : [Scaled Type]
_) = [Scaled Type]
data_con_arg_tys
       (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
unwrapped_res_ty)
       (Maybe Type, CoreExpr -> CoreExpr)
-> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return
         (Maybe Type
maybe_ty, \CoreExpr
e -> CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
data_con))
                                 ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
tycon_arg_tys [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr -> CoreExpr
wrapper CoreExpr
e]))

  | Bool
otherwise
  = String -> SDoc -> DsM (Maybe Type, CoreExpr -> CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"jsResultWrapper" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
result_ty)
  where
    maybe_tc_app :: Maybe (TyCon, [Type])
maybe_tc_app = (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty

-- low-level primitive JavaScript call:
mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
u String
tgt [CoreExpr]
args Type
t = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
u ForeignCall
ccall [CoreExpr]
args Type
t
  where
    ccall :: ForeignCall
ccall = CCallSpec -> ForeignCall
CCall (CCallSpec -> ForeignCall) -> CCallSpec -> ForeignCall
forall a b. (a -> b) -> a -> b
$ CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
              (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText (String -> CLabelString
mkFastString String
tgt) (Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
primUnit) Bool
True)
              CCallConv
JavaScriptCallConv
              Safety
PlayRisky