{-# 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                              = forall a. Pair a -> a
pSnd 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     = forall a. [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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Id
fn_id)
                     (forall a b. (a -> b) -> [a] -> [b]
map 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,
    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
                (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) <- 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 = forall doc. IsLine doc => String -> doc
text (Char
'a'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show a
n)

  type_string :: String
type_string = Platform -> Type -> Char
primTyDescChar Platform
platform Type
res_hty 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 = forall doc. IsLine doc => String -> doc
text String
"h$rts_getUnit"
               | Bool
otherwise       = Type -> SDoc
unpackHObj Type
res_hty

  header_bits :: CHeader
header_bits = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty 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 (forall a. Uniquable a => a -> Unique
getUnique a
i)
            in  SDoc -> CHeader
CHeader (forall doc. IsLine doc => Char -> doc
char Char
tag forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Arity -> doc
int Arity
u)

  fun_args :: SDoc
fun_args
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
arg_info = forall doc. IsOutput doc => doc
empty -- text "void"
    | Bool
otherwise         = forall doc. IsLine doc => [doc] -> doc
hsep forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate forall doc. IsLine doc => doc
comma
                               forall a b. (a -> b) -> a -> b
$ 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
      = forall doc. IsLine doc => String -> doc
text String
"async" forall doc. IsLine doc => doc -> doc -> doc
<+>
        forall doc. IsLine doc => String -> doc
text String
"function" forall doc. IsLine doc => doc -> doc -> doc
<+>
        (if forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target
         then forall doc. IsLine doc => String -> doc
text String
"h$" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm
         else forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm) forall doc. IsLine doc => doc -> doc -> doc
<>
        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 (forall a. NamedThing a => a -> Name
getName Id
hs_fn) ->
            forall doc. IsLine doc => String -> doc
text String
"h$foreignExport" forall doc. IsLine doc => doc -> doc -> doc
<>
                        forall doc. IsLine doc => doc -> doc
parens (
                          forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (UnitId -> String
unitIdString (Module -> UnitId
moduleUnitId Module
m)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (ModuleName -> String
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
m)) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit (CLabelString -> String
unpackFS CLabelString
c_nm) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
strlit String
type_string
                        ) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
          Maybe Id
_ -> 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    -> 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
     = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl 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
_)
             = forall doc. IsLine doc => String -> doc
text String
"h$rts_apply"
               forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (SDoc
acc forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
mkHObj Type
arg_hty forall doc. IsLine doc => doc -> doc -> doc
<> 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 = forall a. Monoid a => a
mempty
                  , getFinalizers :: [CLabel]
getFinalizers   = forall a. Monoid a => a
mempty
                  }
       where js_sdoc :: SDoc
js_sdoc = forall doc. IsLine doc => doc
space
               forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_proto
               forall doc. IsDoc doc => doc -> doc -> doc
$$ forall doc. IsDoc doc => [doc] -> doc
vcat
                 [ forall doc. IsLine doc => doc
lbrace
                 ,   forall doc. IsLine doc => String -> doc
text String
"return"
                     forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"await"
                     forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"h$rts_eval"
                     forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens ((if Bool
is_IO_res_ty
                                 then SDoc
expr_to_run
                                 else forall doc. IsLine doc => String -> doc
text String
"h$rts_toIO" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens SDoc
expr_to_run)
                                forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
unboxResType)
                     forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
                 , forall doc. IsLine doc => doc
rbrace
                 ]
               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 <- 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 forall doc. IsLine doc => String -> doc
text String
"h$" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text (String -> String
zEncodeString String
str)
  | Bool
otherwise
  = 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 = forall a. Pair a -> a
pFst 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 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 (forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
cid Maybe Arity
stdcall_info FunctionOrData
fod))
       rhs' :: CoreExpr
rhs' = 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

   forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
id, CoreExpr
rhs')], forall a. Monoid a => a
mempty, 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                            = 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)               = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"dsJsFExportDynamic: IO type expected"
                                        -- Must have an IO type; hence Just
                                        forall a b. (a -> b) -> a -> b
$ Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
    Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
    Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let fe_nm :: CLabelString
fe_nm = String -> CLabelString
mkFastString forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
            (String
"h$" forall a. [a] -> [a] -> [a]
++ Module -> String
moduleStableString Module
mod forall a. [a] -> [a] -> [a]
++ 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     = HasDebugCallStack => 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      = [ forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (forall a. Integral a => a -> Integer
toInteger (CCallConv -> Arity
ccallConvToInt CCallConv
cconv))
                        , forall b. Id -> Expr b
Var Id
stbl_value
                        , forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm Maybe Arity
mb_sz_args FunctionOrData
IsFunction)
                        , 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 -> forall a. a -> Maybe a
Just Arity
args_size
                        CCallConv
_           -> 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 = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs                  forall a b. (a -> b) -> a -> b
$
                 forall b. b -> Expr b -> Expr b
Lam Id
cback                   forall a b. (a -> b) -> a -> b
$
                 forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
bindIOId)
                        [ forall b. Type -> Expr b
Type Type
stable_ptr_ty
                        , forall b. Type -> Expr b
Type Type
res_ty
                        , forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
newStablePtrId) [ forall b. Type -> Expr b
Type Type
arg_ty, forall b. Id -> Expr b
Var Id
cback ]
                        , 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, 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.

    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 (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                   = forall a. Pair a -> a
pFst 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) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg (forall a b. (a -> b) -> [a] -> [b]
map 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 <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    Unique
work_uniq  <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique

    SimpleOpts
simpl_opts <- DynFlags -> SimpleOpts
initSimpleOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
        tvs :: [Id]
tvs           = forall a b. (a -> b) -> [a] -> [b]
map 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      = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (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     = forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
        wrapper_body :: CoreExpr
wrapper_body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
        wrap_rhs :: CoreExpr
wrap_rhs     = forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
        wrap_rhs' :: CoreExpr
wrap_rhs'    = 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
                                                  (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
args)  CoreExpr
wrap_rhs'

    forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
work_id, CoreExpr
work_rhs), (Id
fn_id_w_inl, CoreExpr
wrap_rhs')], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)


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

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

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

showFFIType :: Type -> String
showFFIType :: Type -> String
showFFIType Type
t = forall a. NamedThing a => a -> String
getOccString (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])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty) -- rep_ty
  = TyCon
tc
  | Bool
otherwise
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"typeTyCon" (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 -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg CoreExpr
arg
  -- Primtive types: nothing to unbox
  | Type -> Bool
isPrimitiveType Type
arg_ty
  = 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 -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxJsArg (HasDebugCallStack => 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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
  = forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
              \ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (forall a. a -> Scaled a
unrestricted Type
boolTy) (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
  = forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg,
              \ CoreExpr
body -> CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase CoreExpr
arg (forall a. a -> Scaled a
unrestricted Type
arg_ty) (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [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 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 (forall a. Scaled a -> a
scaledThing Scaled Type
data_con_arg_ty1)
         forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
prim_arg,
               \ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [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 forall a. Eq a => a -> a -> Bool
== Arity
3 Bool -> Bool -> Bool
&&
    forall a. Maybe a -> Bool
isJust Maybe TyCon
maybe_arg3_tycon Bool -> Bool -> Bool
&&
    (TyCon
arg3_tycon forall a. Eq a => a -> a -> Bool
==  TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
     TyCon
arg3_tycon 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
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
arr_cts_var,
               \ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Id
case_bndr (HasDebugCallStack => CoreExpr -> Type
exprType CoreExpr
body) [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
       forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unboxJsArg: " (forall a. Outputable a => a -> SDoc
ppr SrcSpan
l forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
  where
    arg_ty :: Type
arg_ty                                      = HasDebugCallStack => 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                             = 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 (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 = 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 = forall a. [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 =
                              forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
toIOCon)
                                     [ forall b. Type -> Expr b
Type Type
io_res_ty,
                                       forall b. b -> Expr b -> Expr b
Lam Id
state_id forall a b. (a -> b) -> a -> b
$
                                       CoreExpr -> Scaled Type -> Type -> [CoreAlt] -> CoreExpr
mkWildCase (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Id -> Expr b
Var Id
state_id))
                                             (forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
                                             (CoreAlt -> Type
coreAltType CoreAlt
the_alt)
                                             [CoreAlt
the_alt]
                                     ]

        ; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy HasDebugCallStack => 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 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 (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Id -> Expr b
Var Id
realWorldPrimId))
                                           (forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
                                           (CoreAlt -> Type
coreAltType CoreAlt
the_alt)
                                           [CoreAlt
the_alt]
       forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy HasDebugCallStack => 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 (forall b. Id -> Expr b
Var Id
state_id)
                                     (CoreExpr -> CoreExpr
wrap_result forall a b. (a -> b) -> a -> b
$ 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      = 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
       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 = 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
ls
    [Id]
args_ids <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
args_ids)
        the_rhs :: CoreExpr
the_rhs = CoreExpr -> CoreExpr -> CoreExpr
return_result (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 forall a. a -> [a] -> [a]
: [Type]
ls)
        the_alt :: CoreAlt
the_alt      = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
arity))
                           (Id
state_id forall a. a -> [a] -> [a]
: [Id]
args_ids)
                          CoreExpr
the_rhs
    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 (forall b. Id -> Expr b
Var Id
state_id)
                                (CoreExpr -> CoreExpr
wrap_result (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      = 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
    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
_ = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. a -> a
id) -- fixme this seems like a hack
  -- Base case 1a: unboxed tuples
  | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => 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) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper [Type]
args'
    [Maybe Id]
matched <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy)) [Maybe Type]
tys
    let tys' :: [Type]
tys'    = forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
tys
        -- arity   = length args'
        -- resCon  = tupleDataCon Unboxed (length args)
        err :: a
err     = forall a. HasCallStack => String -> a
panic String
"jsResultWrapper: used Id with result type Nothing"
        resWrap :: CoreExpr
        resWrap :: CoreExpr
resWrap = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\CoreExpr -> CoreExpr
w -> CoreExpr -> CoreExpr
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Id -> Expr b
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err) [CoreExpr -> CoreExpr]
wrappers [Maybe Id]
matched)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys'
        then (forall a. Maybe a
Nothing, \CoreExpr
_ -> CoreExpr
resWrap)
        else let innerArity :: Arity
innerArity = 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 (forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
                                         [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
innerCon)
                                              (forall a. [Maybe a] -> [a]
catMaybes [Maybe Id]
matched)
                                              CoreExpr
resWrap
                                         ]
             in (forall a. a -> Maybe a
Just Type
innerTy, CoreExpr -> CoreExpr
inner)

  -- Base case 1b: primitive types
  | Type -> Bool
isPrimitiveType Type
result_ty
  = forall (m :: * -> *) a. Monad m => a -> m a
return (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) <- HasDebugCallStack => 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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) (forall a. a -> Scaled a
unrestricted Type
innerTy) Type
result_ty
                               [ forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args')))
                                     [Id]
matched
                                     ([CoreExpr] -> CoreExpr
mkCoreTup (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
matched))
                                -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
                               ]
      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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, \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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey = do
--    result_id <- newSysLocalDs boolTy
    Unique
ccall_uniq <- 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
    forall (m :: * -> *) a. Monad m => a -> m a
return
     (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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
anyTyConKey
  = forall (m :: * -> *) a. Monad m => a -> m a
return (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
       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
       forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> 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 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 (forall a. Scaled a -> a
scaledThing Scaled Type
unwrapped_res_ty)
       forall (m :: * -> *) a. Monad m => a -> m a
return
         (Maybe Type
maybe_ty, \CoreExpr
e -> forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
data_con))
                                 (forall a b. (a -> b) -> [a] -> [b]
map forall b. Type -> Expr b
Type [Type]
tycon_arg_tys forall a. [a] -> [a] -> [a]
++ [CoreExpr -> CoreExpr
wrapper CoreExpr
e]))

  | Bool
otherwise
  = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"jsResultWrapper" (forall a. Outputable a => a -> SDoc
ppr Type
result_ty)
  where
    maybe_tc_app :: Maybe (TyCon, [Type])
maybe_tc_app = HasDebugCallStack => 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 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) (forall a. a -> Maybe a
Just Unit
primUnit) Bool
True)
              CCallConv
JavaScriptCallConv
              Safety
PlayRisky