{-# 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.DynFlags
import GHC.Driver.Config

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

import GHC.Data.FastString
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                              = Coercion -> Type
coercionRKind 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 <- 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
    return $
      mkFExportJSBits platform ext_name
                     (if isDyn then Nothing else Just fn_id)
                     (map scaledThing fe_arg_tys) res_ty is_IO_res_ty 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, Word64
u) = Unique -> (Char, Word64)
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
<> Word64 -> SDoc
forall doc. IsLine doc => Word64 -> doc
word64 Word64
u)

  normal_args :: [SDoc]
normal_args = ((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
  all_args :: [SDoc]
all_args
    | Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stableptr_offset" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
normal_args
    | Bool
otherwise              = [SDoc]
normal_args

  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]
all_args

  fun_proto :: SDoc
fun_proto
      = 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
<>
                          CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (UnitId -> CLabelString
unitIdFS (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
<>
                          CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (ModuleName -> CLabelString
moduleNameFS (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
<>
                          CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit 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
<>
                          CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
strlit (String -> CLabelString
mkFastString 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 :: CLabelString -> doc
strlit CLabelString
xs = CLabelString -> doc
forall doc. IsLine doc => CLabelString -> doc
pprStringLit CLabelString
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(stableptr_offset)"
          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
"h$rts_eval_sync"
                     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 = Coercion -> Type
coercionLKind 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
   (_resTy, foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
ty
--   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
   let 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 -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
       stdcall_info = CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info CCallConv
cconv Type
ty

   return ([(id, rhs')], mempty, 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                            = Coercion -> Type
coercionLKind 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
    mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
    platform <- targetPlatform <$> getDynFlags
    let 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].
    cback <- newSysLocalDs arg_mult arg_ty
    newStablePtrId <- dsLookupGlobalId newStablePtrName
    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
    let
        stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
        export_ty     = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
    bindIOId <- dsLookupGlobalId bindIOName
    stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
    (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv 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      = [ 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   = 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 = 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

    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

    let 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 = (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.

    return ([fed], h_code, 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                   = Coercion -> Type
coercionLKind 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

    args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys  -- no FFI levity-polymorphism
    (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args)

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

    (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty

    ccall_uniq <- newUnique
    work_uniq  <- newUnique

    simpl_opts <- initSimpleOpts <$> getDynFlags

    let
        -- Build the worker
        fcall         = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)
        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           = (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 = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
fcall [CoreExpr]
val_args Type
ccall_result_ty
        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       = 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 -> [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 -> 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     = [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 -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
        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'

    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, 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
<> Type -> SDoc
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
<> Type -> SDoc
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
<> Type -> SDoc
showFFIType Type
t

showFFIType :: Type -> SDoc
showFFIType :: Type -> SDoc
showFFIType Type
t = CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext (OccName -> CLabelString
occNameFS (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (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 (HasDebugCallStack => 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) (HasDebugCallStack => 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) (HasDebugCallStack => 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 case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
         prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)
         return (Var 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 (HasDebugCallStack => 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 case_bndr <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
arg_ty
       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
       return (Var 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 (HasDebugCallStack => 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 l <- DsM SrcSpan
getSrcSpanDs
       pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty)
  where
    arg_ty :: Type
arg_ty                                      = HasDebugCallStack => 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


-- 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 -> DsM (Type, CoreExpr -> CoreExpr)
boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
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  { res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
io_res_ty
        ; let return_result CoreExpr
state CoreExpr
ans
                = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple [CoreExpr
state, CoreExpr
ans]

        ; (ccall_res_ty, the_alt) <- mk_alt return_result res

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

              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]
                                     ]

        ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }

boxJsResult Type
result_ty
  = do -- It isn't IO, so do unsafePerformIO
       -- It's not conveniently available, so we inline it
       res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
result_ty
       (ccall_res_ty, the_alt) <- mk_alt return_result res
       let
           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]
       return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, 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 ()
       state_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
realWorldStatePrimTy
       let
             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 = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
             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
       return (ccall_res_ty, 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
    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
    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
    let
        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 -> 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 = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed (Type
realWorldStatePrimTy Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
ls)
        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
    return (ccall_res_ty, the_alt)

  | Bool
otherwise = do
    result_id <- Type -> Type -> DsM Id
newSysLocalDs Type
ManyTy Type
prim_res_ty
    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
    let
        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 = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
        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
    return (ccall_res_ty, 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
  -- Base case 1a: unboxed tuples
  | Just (TyCon
tc, [Type]
args) <- HasDebugCallStack => 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
    (tys, 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'
    matched <- mapM (mapM (newSysLocalDs ManyTy)) tys
    let tys'    = [Maybe Type] -> [Type]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Type]
tys
        -- arity   = length args'
        -- resCon  = tupleDataCon Unboxed (length args)
        err     = String -> a
forall a. HasCallStack => String -> a
panic String
"jsResultWrapper: used Id with result type Nothing"
        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)
    return $
      if null tys'
        then (Nothing, \CoreExpr
_ -> CoreExpr
resWrap)
        else let innerArity = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys'
                 innerTy    = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type]
tys'
                 innerCon   = Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
innerArity
                 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 (Just innerTy, 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) <- HasDebugCallStack => 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'
      (inner_res, w) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
innerTy
      matched <- mapM (newSysLocalDs ManyTy) args'
      let 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)
                               ]
      return (inner_res, 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
    ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
    let forceBool CoreExpr
e = Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
ccall_uniq (String -> CLabelString
fsLit String
"((x) => { return !(!x); })") [CoreExpr
e] Type
boolTy
    return
     (Just 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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rep_ty
       return (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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper Type
rest
       return (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_ty, wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
jsResultWrapper (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
unwrapped_res_ty)
       return
         (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 = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty

-- low-level primitive JavaScript call:
mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall :: Unique -> CLabelString -> [CoreExpr] -> Type -> CoreExpr
mkJsCall Unique
u CLabelString
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 CLabelString
tgt (Unit -> Maybe Unit
forall a. a -> Maybe a
Just Unit
primUnit) Bool
True)
              CCallConv
JavaScriptCallConv
              Safety
PlayRisky