Split GHC.HsToCore.Foreign.Decl

This is preliminary work for JavaScript support. It's better to put the
code handling the desugaring of Prim, C and JavaScript declarations into
separate modules.

5 files changed, 762 insertions, 665 deletions

diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
new file mode 100644
index 0000000000..555db51840
--- /dev/null
+++ b/compiler/GHC/HsToCore/Foreign/C.hs
@@ -0,0 +1,627 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+-- | Handling of C foreign imports/exports
+module GHC.HsToCore.Foreign.C
+  ( dsCImport
+  , dsCFExport
+  , dsCFExportDynamic
+  )
+where
+
+import GHC.Prelude
+
+import GHC.Platform
+
+import GHC.Tc.Utils.Monad        -- temp
+import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.TcType
+
+import GHC.Core
+import GHC.Core.Unfold.Make
+import GHC.Core.Type
+import GHC.Core.TyCon
+import GHC.Core.Coercion
+import GHC.Core.Multiplicity
+
+import GHC.HsToCore.Foreign.Call
+import GHC.HsToCore.Foreign.Prim
+import GHC.HsToCore.Foreign.Utils
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Types (ds_next_wrapper_num)
+
+import GHC.Hs
+
+import GHC.Types.Id
+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.Unit.Module
+
+import GHC.Driver.Session
+import GHC.Driver.Config
+
+import GHC.Cmm.Expr
+import GHC.Cmm.Utils
+
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
+import GHC.Builtin.Names
+
+import GHC.Data.FastString
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+import GHC.Utils.Encoding
+
+import Data.Maybe
+import Data.List (nub)
+
+dsCFExport:: 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
+                 )
+
+dsCFExport fn_id co ext_name cconv isDyn = do
+    let
+       ty                     = coercionRKind co
+       (bndrs, orig_res_ty)   = tcSplitPiTys ty
+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
+       -- We must use tcSplits here, because we want to see
+       -- the (IO t) in the corner of the type!
+       fe_arg_tys | isDyn     = tail fe_arg_tys'
+                  | otherwise = 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)
+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
+                                -- The function already returns IO t
+                                Just (_ioTyCon, res_ty) -> (res_ty, True)
+                                -- The function returns t
+                                Nothing                 -> (orig_res_ty, False)
+
+    dflags <- getDynFlags
+    return $
+      mkFExportCBits dflags ext_name
+                     (if isDyn then Nothing else Just fn_id)
+                     fe_arg_tys res_ty is_IO_res_ty cconv
+
+dsCImport :: Id
+          -> Coercion
+          -> CImportSpec
+          -> CCallConv
+          -> Safety
+          -> Maybe Header
+          -> DsM ([Binding], CHeader, CStub)
+dsCImport id co (CLabel cid) cconv _ _ = do
+   dflags <- getDynFlags
+   let ty  = coercionLKind co
+       platform = targetPlatform dflags
+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
+             Just tycon
+              | tyConUnique tycon == funPtrTyConKey ->
+                 IsFunction
+             _ -> IsData
+   (resTy, foRhs) <- resultWrapper ty
+   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
+    let
+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+        rhs' = Cast rhs co
+        stdcall_info = fun_type_arg_stdcall_info platform cconv ty
+    in
+    return ([(id, rhs')], mempty, mempty)
+
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co (CFunction target) cconv safety mHeader
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
+dsCImport id co CWrapper cconv _ _
+  = dsCFExportDynamic id co cconv
+
+
+{-
+@foreign import "wrapper"@ (previously "foreign export dynamic") lets
+you dress up Haskell IO actions of some fixed type behind an
+externally callable interface (i.e., as a C function pointer). Useful
+for callbacks and stuff.
+
+\begin{verbatim}
+type Fun = Bool -> Int -> IO Int
+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: Fun -> IO (FunPtr Fun)
+f cback =
+   bindIO (newStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
+
+-- and the helper in C: (approximately; see `mkFExportCBits` below)
+
+f_helper(StablePtr s, HsBool b, HsInt i)
+{
+        Capability *cap;
+        cap = rts_lock();
+        rts_inCall(&cap,
+                   rts_apply(rts_apply(deRefStablePtr(s),
+                                       rts_mkBool(b)), rts_mkInt(i)));
+        rts_unlock(cap);
+}
+\end{verbatim}
+-}
+dsCFExportDynamic :: Id
+                 -> Coercion
+                 -> CCallConv
+                 -> DsM ([Binding], CHeader, CStub)
+dsCFExportDynamic id co0 cconv = do
+    mod <- getModule
+    dflags <- getDynFlags
+    let platform = targetPlatform dflags
+    let fe_nm = mkFastString $ zEncodeString
+            (moduleStableString mod ++ "$" ++ toCName 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 = mkTyConApp stable_ptr_tycon [arg_ty]
+        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
+    bindIOId <- dsLookupGlobalId bindIOName
+    stbl_value <- newSysLocalDs Many stable_ptr_ty
+    (h_code, c_code, typestring, args_size) <- dsCFExport 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      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
+                        , Var stbl_value
+                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+                        , Lit (mkLitString typestring)
+                        ]
+          -- name of external entry point providing these services.
+          -- (probably in the RTS.)
+        adjustor   = fsLit "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 cconv of
+                        StdCallConv -> Just args_size
+                        _           -> 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 = mkLams tvs                  $
+                 Lam cback                   $
+                 mkApps (Var bindIOId)
+                        [ Type stable_ptr_ty
+                        , Type res_ty
+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+                        , Lam stbl_value ccall_adj
+                        ]
+
+        fed = (id `setInlineActivation` NeverActive, Cast io_app 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)
+
+ where
+  ty                       = coercionLKind co0
+  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty
+  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
+        -- Must have an IO type; hence Just
+
+
+-- | Foreign calls
+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
+dsFCall fn_id co fcall mDeclHeader = do
+    let
+        ty                   = coercionLKind co
+        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
+        (arg_tys, io_res_ty) = tcSplitFunTys rho
+
+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
+
+    let
+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
+
+    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
+
+    ccall_uniq <- newUnique
+    work_uniq  <- newUnique
+
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
+                               CApiConv safety) ->
+               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
+                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
+                  let fcall' = CCall (CCallSpec
+                                      (StaticTarget NoSourceText
+                                                    wrapperName mUnitId
+                                                    True)
+                                      CApiConv safety)
+                      c = includes
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
+                                      | Header _ h <- nub headers ]
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = if isFun
+                              then ppr cName <> parens argVals
+                              else if null arg_tys
+                                    then ppr cName
+                                    else panic "dsFCall: Unexpected arguments to FFI value import"
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      (mHeader, cResType)
+                       | isVoidRes = (Nothing, text "void")
+                       | otherwise = toCType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      mHeadersArgTypeList
+                          = [ (header, cType <+> char 'a' <> int n)
+                            | (t, n) <- zip arg_tys [1..]
+                            , let (header, cType) = toCType (scaledThing t) ]
+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
+                      argTypes = if null argTypeList
+                                 then text "void"
+                                 else hsep $ punctuate comma argTypeList
+                      mHeaders' = mDeclHeader : mHeader : mHeaders
+                      headers = catMaybes mHeaders'
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
+    dflags <- getDynFlags
+    let
+        -- Build the worker
+        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
+        tvs           = map binderVar tv_bndrs
+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
+
+        -- Build the wrapper
+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        wrap_rhs'    = Cast wrap_rhs co
+        simpl_opts   = initSimpleOpts dflags
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
+                                                (length args)
+                                                simpl_opts
+                                                wrap_rhs'
+
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
+
+
+toCName :: Id -> String
+toCName i = renderWithContext defaultSDocContext (pprCode CStyle (ppr (idName i)))
+
+toCType :: Type -> (Maybe Header, SDoc)
+toCType = f False
+    where f voidOK t
+           -- First, if we have (Ptr t) of (FunPtr t), then we need to
+           -- convert t to a C type and put a * after it. If we don't
+           -- know a type for t, then "void" is fine, though.
+           | Just (ptr, [t']) <- splitTyConApp_maybe t
+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
+              = case f True t' of
+                (mh, cType') ->
+                    (mh, cType' <> char '*')
+           -- Otherwise, if we have a type constructor application, then
+           -- see if there is a C type associated with that constructor.
+           -- Note that we aren't looking through type synonyms or
+           -- anything, as it may be the synonym that is annotated.
+           | Just tycon <- tyConAppTyConPicky_maybe t
+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
+              = (mHeader, ftext cType)
+           -- If we don't know a C type for this type, then try looking
+           -- through one layer of type synonym etc.
+           | Just t' <- coreView t
+              = f voidOK t'
+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
+           -- (which is marshalled like a Ptr)
+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
+              = (Nothing, text "void*")
+           -- Otherwise we don't know the C type. If we are allowing
+           -- void then return that; otherwise something has gone wrong.
+           | voidOK = (Nothing, text "void")
+           | otherwise
+              = pprPanic "toCType" (ppr t)
+
+{-
+*
+
+\subsection{Generating @foreign export@ stubs}
+
+*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
+-}
+
+mkFExportCBits :: DynFlags
+               -> 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
+                  )
+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+ = ( header_bits
+   , CStub body [] []
+   , type_string,
+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_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
+  platform = targetPlatform dflags
+
+  -- list the arguments to the C function
+  arg_info :: [(SDoc,           -- arg name
+                SDoc,           -- C type
+                Type,           -- Haskell type
+                CmmType)]       -- the CmmType
+  arg_info  = [ let stg_type = showStgType ty in
+                (arg_cname n stg_type,
+                 stg_type,
+                 ty,
+                typeCmmType platform (getPrimTyOf ty))
+              | (ty,n) <- zip arg_htys [1::Int ..] ]
+
+  arg_cname n stg_ty
+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
+                      text "args" <> brackets (int (n-1))
+        | otherwise = text ('a':show n)
+
+  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
+  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
+
+  type_string
+      -- libffi needs to know the result type too:
+      | libffi    = primTyDescChar platform res_hty : arg_type_string
+      | otherwise = arg_type_string
+
+  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
+                -- just the real args
+
+  -- add some auxiliary args; the stable ptr in the wrapper case, and
+  -- a slot for the dummy return address in the wrapper + ccall case
+  aug_arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
+    | otherwise              = arg_info
+
+  stable_ptr_arg =
+        (text "the_stableptr", text "StgStablePtr", undefined,
+         typeCmmType platform (mkStablePtrPrimTy alphaTy))
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+           | otherwise       = showStgType res_hty
+
+  -- when the return type is integral and word-sized or smaller, it
+  -- must be assigned as type ffi_arg (#3516).  To see what type
+  -- libffi is expecting here, take a look in its own testsuite, e.g.
+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
+  ffi_cResType
+     | is_ffi_arg_type = text "ffi_arg"
+     | otherwise       = cResType
+     where
+       res_ty_key = getUnique (getName (typeTyCon res_hty))
+       is_ffi_arg_type = res_ty_key `notElem`
+              [floatTyConKey, doubleTyConKey,
+               int64TyConKey, word64TyConKey]
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = ccallConvAttribute cc
+
+  header_bits = CHeader (text "extern" <+> fun_proto <> semi)
+
+  fun_args
+    | null aug_arg_info = text "void"
+    | otherwise         = hsep $ punctuate comma
+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
+
+  fun_proto
+    | libffi
+      = text "void" <+> ftext c_nm <>
+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
+    | otherwise
+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
+
+  -- the target which will form the root of what we ask rts_inCall to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+  cap = text "cap" <> comma
+
+  -- the expression we give to rts_inCall
+  expr_to_run
+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
+       where
+          appArg acc (arg_cname, _, arg_hty, _)
+             = text "rts_apply"
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+  declareCResult | res_hty_is_unit = empty
+                 | otherwise       = cResType <+> text "cret;"
+
+  assignCResult | res_hty_is_unit = empty
+                | otherwise       =
+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+
+  -- finally, the whole darn thing
+  body =
+    space $$
+    extern_decl $$
+    fun_proto  $$
+    vcat
+     [ lbrace
+     ,   text "Capability *cap;"
+     ,   declareResult
+     ,   declareCResult
+     ,   text "cap = rts_lock();"
+          -- create the application + perform it.
+     ,   text "rts_inCall" <> parens (
+                char '&' <> cap <>
+                text "rts_apply" <> parens (
+                    cap <>
+                    text "(HaskellObj)"
+                 <> (if is_IO_res_ty
+                      then text "runIO_closure"
+                      else text "runNonIO_closure")
+                 <> comma
+                 <> expr_to_run
+                ) <+> comma
+               <> text "&ret"
+             ) <> semi
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+                                                <> comma <> text "cap") <> semi
+     ,   assignCResult
+     ,   text "rts_unlock(cap);"
+     ,   ppUnless res_hty_is_unit $
+         if libffi
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
+                       text "resp = cret;"
+                  else text "return cret;"
+     , rbrace
+     ]
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName (typeTyCon t))
+
+typeTyCon :: Type -> TyCon
+typeTyCon ty
+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
+  = tc
+  | otherwise
+  = pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty)
+
+
+insertRetAddr :: Platform -> CCallConv
+              -> [(SDoc, SDoc, Type, CmmType)]
+              -> [(SDoc, SDoc, Type, CmmType)]
+insertRetAddr platform CCallConv args
+    = case platformArch platform of
+      ArchX86_64
+       | platformOS platform == OSMinGW32 ->
+          -- On other Windows x86_64 we insert the return address
+          -- after the 4th argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 4 args = ret_addr_arg platform : args
+              go n (arg:args) = arg : go (n+1) args
+              go _ [] = []
+          in go 0 args
+       | otherwise ->
+          -- On other x86_64 platforms we insert the return address
+          -- after the 6th integer argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 6 args = ret_addr_arg platform : args
+              go n (arg@(_,_,_,rep):args)
+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
+               | otherwise  = arg : go n     args
+              go _ [] = []
+          in go 0 args
+      _ ->
+          ret_addr_arg platform : args
+insertRetAddr _ _ args = args
+
+ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
+ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
+                         typeCmmType platform addrPrimTy)
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info platform StdCallConv ty
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
+    tyConUnique tc == funPtrTyConKey
+  = let
+       (bndrs, _) = tcSplitPiTys arg_ty
+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _ _other_conv _
+  = Nothing
+
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 68980f5b12..29bfb689e8 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -7,63 +7,39 @@
 {-
 (c) The University of Glasgow 2006
 (c) The AQUA Project, Glasgow University, 1998
-
-
-Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call).
 -}
 
-module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
+-- | Desugaring foreign declarations
+module GHC.HsToCore.Foreign.Decl
+  ( dsForeigns
+  )
+where
 
 import GHC.Prelude
 
 import GHC.Tc.Utils.Monad        -- temp
 
-import GHC.Core
-
-import GHC.HsToCore.Foreign.Call
+import GHC.HsToCore.Foreign.C
+import GHC.HsToCore.Foreign.Utils
 import GHC.HsToCore.Monad
-import GHC.HsToCore.Types (ds_next_wrapper_num)
 
 import GHC.Hs
-import GHC.Core.DataCon
-import GHC.Core.Unfold.Make
 import GHC.Types.Id
-import GHC.Types.Literal
 import GHC.Types.ForeignStubs
-import GHC.Types.SourceText
 import GHC.Unit.Module
-import GHC.Types.Name
-import GHC.Core.Type
-import GHC.Types.RepType
-import GHC.Core.TyCon
 import GHC.Core.Coercion
-import GHC.Core.Multiplicity
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
 
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
 import GHC.Cmm.CLabel
-import GHC.Driver.Ppr
 import GHC.Types.ForeignCall
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names
-import GHC.Types.Basic
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
-import GHC.Data.FastString
 import GHC.Driver.Session
-import GHC.Driver.Config
 import GHC.Platform
 import GHC.Data.OrdList
 import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
 import GHC.Driver.Hooks
-import GHC.Utils.Encoding
 
-import Data.Maybe
-import Data.List (unzip4, nub)
+import Data.List (unzip4)
 
 {-
 Desugaring of @foreign@ declarations is naturally split up into
@@ -80,9 +56,6 @@ is the same as
 so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
 -}
 
-type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-                              -- the occurrence analyser will sort it all out
-
 dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
 dsForeigns fos = do
     hooks <- getHooks
@@ -158,182 +131,6 @@ dsFImport :: Id
 dsFImport id co (CImport cconv safety mHeader spec _) =
     dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
 
-dsCImport :: Id
-          -> Coercion
-          -> CImportSpec
-          -> CCallConv
-          -> Safety
-          -> Maybe Header
-          -> DsM ([Binding], CHeader, CStub)
-dsCImport id co (CLabel cid) cconv _ _ = do
-   dflags <- getDynFlags
-   let ty  = coercionLKind co
-       platform = targetPlatform dflags
-       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
-             Just tycon
-              | tyConUnique tycon == funPtrTyConKey ->
-                 IsFunction
-             _ -> IsData
-   (resTy, foRhs) <- resultWrapper ty
-   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
-    let
-        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
-        rhs' = Cast rhs co
-        stdcall_info = fun_type_arg_stdcall_info platform cconv ty
-    in
-    return ([(id, rhs')], mempty, mempty)
-
-dsCImport id co (CFunction target) cconv@PrimCallConv safety _
-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co (CFunction target) cconv safety mHeader
-  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
-dsCImport id co CWrapper cconv _ _
-  = dsFExportDynamic id co cconv
-
--- For stdcall labels, if the type was a FunPtr or newtype thereof,
--- then we need to calculate the size of the arguments in order to add
--- the @n suffix to the label.
-fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info platform StdCallConv ty
-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
-    tyConUnique tc == funPtrTyConKey
-  = let
-       (bndrs, _) = tcSplitPiTys arg_ty
-       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
-fun_type_arg_stdcall_info _ _other_conv _
-  = Nothing
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Foreign calls}
-*                                                                      *
-************************************************************************
--}
-
-dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
-dsFCall fn_id co fcall mDeclHeader = do
-    let
-        ty                   = coercionLKind co
-        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
-        (arg_tys, io_res_ty) = tcSplitFunTys rho
-
-    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
-    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
-
-    let
-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
-
-    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
-
-    ccall_uniq <- newUnique
-    work_uniq  <- newUnique
-
-    (fcall', cDoc) <-
-              case fcall of
-              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
-                               CApiConv safety) ->
-               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
-                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
-                  let fcall' = CCall (CCallSpec
-                                      (StaticTarget NoSourceText
-                                                    wrapperName mUnitId
-                                                    True)
-                                      CApiConv safety)
-                      c = includes
-                       $$ fun_proto <+> braces (cRet <> semi)
-                      includes = vcat [ text "#include \"" <> ftext h
-                                        <> text "\""
-                                      | Header _ h <- nub headers ]
-                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
-                      cRet
-                       | isVoidRes =                   cCall
-                       | otherwise = text "return" <+> cCall
-                      cCall = if isFun
-                              then ppr cName <> parens argVals
-                              else if null arg_tys
-                                    then ppr cName
-                                    else panic "dsFCall: Unexpected arguments to FFI value import"
-                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
-                                   Just (_ioTyCon, res_ty) -> res_ty
-                                   Nothing                 -> io_res_ty
-                      isVoidRes = raw_res_ty `eqType` unitTy
-                      (mHeader, cResType)
-                       | isVoidRes = (Nothing, text "void")
-                       | otherwise = toCType raw_res_ty
-                      pprCconv = ccallConvAttribute CApiConv
-                      mHeadersArgTypeList
-                          = [ (header, cType <+> char 'a' <> int n)
-                            | (t, n) <- zip arg_tys [1..]
-                            , let (header, cType) = toCType (scaledThing t) ]
-                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
-                      argTypes = if null argTypeList
-                                 then text "void"
-                                 else hsep $ punctuate comma argTypeList
-                      mHeaders' = mDeclHeader : mHeader : mHeaders
-                      headers = catMaybes mHeaders'
-                      argVals = hsep $ punctuate comma
-                                    [ char 'a' <> int n
-                                    | (_, n) <- zip arg_tys [1..] ]
-                  return (fcall', c)
-              _ ->
-                  return (fcall, empty)
-    dflags <- getDynFlags
-    let
-        -- Build the worker
-        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
-        tvs           = map binderVar tv_bndrs
-        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
-
-        -- Build the wrapper
-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        wrap_rhs'    = Cast wrap_rhs co
-        simpl_opts   = initSimpleOpts dflags
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
-                                                (length args)
-                                                simpl_opts
-                                                wrap_rhs'
-
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Primitive calls}
-*                                                                      *
-************************************************************************
-
-This is for `@foreign import prim@' declarations.
-
-Currently, at the core level we pretend that these primitive calls are
-foreign calls. It may make more sense in future to have them as a distinct
-kind of Id, or perhaps to bundle them with PrimOps since semantically and
-for calling convention they are really prim ops.
--}
-
-dsPrimCall :: Id -> Coercion -> ForeignCall
-           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
-dsPrimCall fn_id co fcall = do
-    let
-        ty                   = coercionLKind co
-        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty
-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-
-    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
-
-    ccall_uniq <- newUnique
-    let
-        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
-        rhs      = mkLams tvs (mkLams args call_app)
-        rhs'     = Cast rhs co
-    return ([(fn_id, rhs')], mempty, mempty)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -367,324 +164,10 @@ dsFExport :: Id                 -- Either the exported Id,
                  , String       -- string describing type to pass to createAdj.
                  , Int          -- size of args to stub function
                  )
+dsFExport fn_id co ext_name cconv is_dyn = case cconv of
+  JavaScriptCallConv -> panic "dsFExport: JavaScript foreign exports not supported yet"
+  _                  -> dsCFExport  fn_id co ext_name cconv is_dyn
 
-dsFExport fn_id co ext_name cconv isDyn = do
-    let
-       ty                     = coercionRKind co
-       (bndrs, orig_res_ty)   = tcSplitPiTys ty
-       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
-       -- We must use tcSplits here, because we want to see
-       -- the (IO t) in the corner of the type!
-       fe_arg_tys | isDyn     = tail fe_arg_tys'
-                  | otherwise = 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)
-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
-                                -- The function already returns IO t
-                                Just (_ioTyCon, res_ty) -> (res_ty, True)
-                                -- The function returns t
-                                Nothing                 -> (orig_res_ty, False)
-
-    dflags <- getDynFlags
-    return $
-      mkFExportCBits dflags ext_name
-                     (if isDyn then Nothing else Just fn_id)
-                     fe_arg_tys res_ty is_IO_res_ty cconv
-
-{-
-@foreign import "wrapper"@ (previously "foreign export dynamic") lets
-you dress up Haskell IO actions of some fixed type behind an
-externally callable interface (i.e., as a C function pointer). Useful
-for callbacks and stuff.
-
-\begin{verbatim}
-type Fun = Bool -> Int -> IO Int
-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
-
--- Haskell-visible constructor, which is generated from the above:
--- SUP: No check for NULL from createAdjustor anymore???
-
-f :: Fun -> IO (FunPtr Fun)
-f cback =
-   bindIO (newStablePtr cback)
-          (\StablePtr sp# -> IO (\s1# ->
-              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
-                 (# s2#, a# #) -> (# s2#, A# a# #)))
-
-foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
-
--- and the helper in C: (approximately; see `mkFExportCBits` below)
-
-f_helper(StablePtr s, HsBool b, HsInt i)
-{
-        Capability *cap;
-        cap = rts_lock();
-        rts_inCall(&cap,
-                   rts_apply(rts_apply(deRefStablePtr(s),
-                                       rts_mkBool(b)), rts_mkInt(i)));
-        rts_unlock(cap);
-}
-\end{verbatim}
--}
-
-dsFExportDynamic :: Id
-                 -> Coercion
-                 -> CCallConv
-                 -> DsM ([Binding], CHeader, CStub)
-dsFExportDynamic id co0 cconv = do
-    mod <- getModule
-    dflags <- getDynFlags
-    let platform = targetPlatform dflags
-    let fe_nm = mkFastString $ zEncodeString
-            (moduleStableString mod ++ "$" ++ toCName dflags 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 = mkTyConApp stable_ptr_tycon [arg_ty]
-        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
-    bindIOId <- dsLookupGlobalId bindIOName
-    stbl_value <- newSysLocalDs Many stable_ptr_ty
-    (h_code, c_code, typestring, args_size) <- dsFExport 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      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
-                        , Var stbl_value
-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
-                        , Lit (mkLitString typestring)
-                        ]
-          -- name of external entry point providing these services.
-          -- (probably in the RTS.)
-        adjustor   = fsLit "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 cconv of
-                        StdCallConv -> Just args_size
-                        _           -> 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 = mkLams tvs                  $
-                 Lam cback                   $
-                 mkApps (Var bindIOId)
-                        [ Type stable_ptr_ty
-                        , Type res_ty
-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
-                        , Lam stbl_value ccall_adj
-                        ]
-
-        fed = (id `setInlineActivation` NeverActive, Cast io_app 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)
-
- where
-  ty                       = coercionLKind co0
-  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty
-  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
-        -- Must have an IO type; hence Just
-
-
-toCName :: DynFlags -> Id -> String
-toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
-
-{-
-*
-
-\subsection{Generating @foreign export@ stubs}
-
-*
-
-For each @foreign export@ function, a C stub function is generated.
-The C stub constructs the application of the exported Haskell function
-using the hugs/ghc rts invocation API.
--}
-
-mkFExportCBits :: DynFlags
-               -> 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
-                  )
-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = ( header_bits
-   , CStub body [] []
-   , type_string,
-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_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
-  platform = targetPlatform dflags
-
-  -- list the arguments to the C function
-  arg_info :: [(SDoc,           -- arg name
-                SDoc,           -- C type
-                Type,           -- Haskell type
-                CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = showStgType ty in
-                (arg_cname n stg_type,
-                 stg_type,
-                 ty,
-                typeCmmType platform (getPrimTyOf ty))
-              | (ty,n) <- zip arg_htys [1::Int ..] ]
-
-  arg_cname n stg_ty
-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
-                      text "args" <> brackets (int (n-1))
-        | otherwise = text ('a':show n)
-
-  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
-  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
-
-  type_string
-      -- libffi needs to know the result type too:
-      | libffi    = primTyDescChar platform res_hty : arg_type_string
-      | otherwise = arg_type_string
-
-  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
-                -- just the real args
-
-  -- add some auxiliary args; the stable ptr in the wrapper case, and
-  -- a slot for the dummy return address in the wrapper + ccall case
-  aug_arg_info
-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
-    | otherwise              = arg_info
-
-  stable_ptr_arg =
-        (text "the_stableptr", text "StgStablePtr", undefined,
-         typeCmmType platform (mkStablePtrPrimTy alphaTy))
-
-  -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
-
-  cResType | res_hty_is_unit = text "void"
-           | otherwise       = showStgType res_hty
-
-  -- when the return type is integral and word-sized or smaller, it
-  -- must be assigned as type ffi_arg (#3516).  To see what type
-  -- libffi is expecting here, take a look in its own testsuite, e.g.
-  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
-  ffi_cResType
-     | is_ffi_arg_type = text "ffi_arg"
-     | otherwise       = cResType
-     where
-       res_ty_key = getUnique (getName (typeTyCon res_hty))
-       is_ffi_arg_type = res_ty_key `notElem`
-              [floatTyConKey, doubleTyConKey,
-               int64TyConKey, word64TyConKey]
-
-  -- Now we can cook up the prototype for the exported function.
-  pprCconv = ccallConvAttribute cc
-
-  header_bits = CHeader (text "extern" <+> fun_proto <> semi)
-
-  fun_args
-    | null aug_arg_info = text "void"
-    | otherwise         = hsep $ punctuate comma
-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
-
-  fun_proto
-    | libffi
-      = text "void" <+> ftext c_nm <>
-          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
-    | otherwise
-      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
-
-  -- the target which will form the root of what we ask rts_inCall to run
-  the_cfun
-     = case maybe_target of
-          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
-
-  cap = text "cap" <> comma
-
-  -- the expression we give to rts_inCall
-  expr_to_run
-     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
-       where
-          appArg acc (arg_cname, _, arg_hty, _)
-             = text "rts_apply"
-               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
-
-  -- various other bits for inside the fn
-  declareResult = text "HaskellObj ret;"
-  declareCResult | res_hty_is_unit = empty
-                 | otherwise       = cResType <+> text "cret;"
-
-  assignCResult | res_hty_is_unit = empty
-                | otherwise       =
-                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
-
-  -- an extern decl for the fn being called
-  extern_decl
-     = case maybe_target of
-          Nothing -> empty
-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
-
-
-  -- finally, the whole darn thing
-  body =
-    space $$
-    extern_decl $$
-    fun_proto  $$
-    vcat
-     [ lbrace
-     ,   text "Capability *cap;"
-     ,   declareResult
-     ,   declareCResult
-     ,   text "cap = rts_lock();"
-          -- create the application + perform it.
-     ,   text "rts_inCall" <> parens (
-                char '&' <> cap <>
-                text "rts_apply" <> parens (
-                    cap <>
-                    text "(HaskellObj)"
-                 <> (if is_IO_res_ty
-                      then text "runIO_closure"
-                      else text "runNonIO_closure")
-                 <> comma
-                 <> expr_to_run
-                ) <+> comma
-               <> text "&ret"
-             ) <> semi
-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
-                                                <> comma <> text "cap") <> semi
-     ,   assignCResult
-     ,   text "rts_unlock(cap);"
-     ,   ppUnless res_hty_is_unit $
-         if libffi
-                  then char '*' <> parens (ffi_cResType <> char '*') <>
-                       text "resp = cret;"
-                  else text "return cret;"
-     , rbrace
-     ]
 
 foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
 foreignExportsInitialiser _        _   []     = mempty
@@ -716,140 +199,3 @@ foreignExportsInitialiser platform mod hs_fns =
     closure_ptr :: Id -> SDoc
     closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
 
-
-mkHObj :: Type -> SDoc
-mkHObj t = text "rts_mk" <> text (showFFIType t)
-
-unpackHObj :: Type -> SDoc
-unpackHObj t = text "rts_get" <> text (showFFIType t)
-
-showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> text (showFFIType t)
-
-showFFIType :: Type -> String
-showFFIType t = getOccString (getName (typeTyCon t))
-
-toCType :: Type -> (Maybe Header, SDoc)
-toCType = f False
-    where f voidOK t
-           -- First, if we have (Ptr t) of (FunPtr t), then we need to
-           -- convert t to a C type and put a * after it. If we don't
-           -- know a type for t, then "void" is fine, though.
-           | Just (ptr, [t']) <- splitTyConApp_maybe t
-           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
-              = case f True t' of
-                (mh, cType') ->
-                    (mh, cType' <> char '*')
-           -- Otherwise, if we have a type constructor application, then
-           -- see if there is a C type associated with that constructor.
-           -- Note that we aren't looking through type synonyms or
-           -- anything, as it may be the synonym that is annotated.
-           | Just tycon <- tyConAppTyConPicky_maybe t
-           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
-              = (mHeader, ftext cType)
-           -- If we don't know a C type for this type, then try looking
-           -- through one layer of type synonym etc.
-           | Just t' <- coreView t
-              = f voidOK t'
-           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
-           -- (which is marshalled like a Ptr)
-           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
-              = (Nothing, text "const void*")
-           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
-              = (Nothing, text "void*")
-           -- Otherwise we don't know the C type. If we are allowing
-           -- void then return that; otherwise something has gone wrong.
-           | voidOK = (Nothing, text "void")
-           | otherwise
-              = pprPanic "toCType" (ppr t)
-
-typeTyCon :: Type -> TyCon
-typeTyCon ty
-  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
-  = tc
-  | otherwise
-  = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
-
-insertRetAddr :: Platform -> CCallConv
-              -> [(SDoc, SDoc, Type, CmmType)]
-              -> [(SDoc, SDoc, Type, CmmType)]
-insertRetAddr platform CCallConv args
-    = case platformArch platform of
-      ArchX86_64
-       | platformOS platform == OSMinGW32 ->
-          -- On other Windows x86_64 we insert the return address
-          -- after the 4th argument, because this is the point
-          -- at which we need to flush a register argument to the stack
-          -- (See rts/Adjustor.c for details).
-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-                        -> [(SDoc, SDoc, Type, CmmType)]
-              go 4 args = ret_addr_arg platform : args
-              go n (arg:args) = arg : go (n+1) args
-              go _ [] = []
-          in go 0 args
-       | otherwise ->
-          -- On other x86_64 platforms we insert the return address
-          -- after the 6th integer argument, because this is the point
-          -- at which we need to flush a register argument to the stack
-          -- (See rts/Adjustor.c for details).
-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-                        -> [(SDoc, SDoc, Type, CmmType)]
-              go 6 args = ret_addr_arg platform : args
-              go n (arg@(_,_,_,rep):args)
-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
-               | otherwise  = arg : go n     args
-              go _ [] = []
-          in go 0 args
-      _ ->
-          ret_addr_arg platform : args
-insertRetAddr _ _ args = args
-
-ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
-ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
-                         typeCmmType platform addrPrimTy)
-
--- This function returns the primitive type associated with the boxed
--- type argument to a foreign export (eg. Int ==> Int#).
-getPrimTyOf :: Type -> UnaryType
-getPrimTyOf ty
-  | isBoolTy rep_ty = intPrimTy
-  -- Except for Bool, the types we are interested in have a single constructor
-  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
-  | otherwise =
-  case splitDataProductType_maybe rep_ty of
-     Just (_, _, data_con, [Scaled _ prim_ty]) ->
-        assert (dataConSourceArity data_con == 1) $
-        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
-          -- NB: it's OK to call isUnliftedType here, as we don't allow
-          -- representation-polymorphic types in foreign import/export declarations
-        prim_ty
-     _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
-  where
-        rep_ty = unwrapType ty
-
--- represent a primitive type as a Char, for building a string that
--- described the foreign function type.  The types are size-dependent,
--- e.g. 'W' is a signed 32-bit integer.
-primTyDescChar :: Platform -> Type -> Char
-primTyDescChar platform ty
- | ty `eqType` unitTy = 'v'
- | otherwise
- = case typePrimRep1 (getPrimTyOf ty) of
-     IntRep      -> signed_word
-     WordRep     -> unsigned_word
-     Int8Rep     -> 'B'
-     Word8Rep    -> 'b'
-     Int16Rep    -> 'S'
-     Word16Rep   -> 's'
-     Int32Rep    -> 'W'
-     Word32Rep   -> 'w'
-     Int64Rep    -> 'L'
-     Word64Rep   -> 'l'
-     AddrRep     -> 'p'
-     FloatRep    -> 'f'
-     DoubleRep   -> 'd'
-     _           -> pprPanic "primTyDescChar" (ppr ty)
-  where
-    (signed_word, unsigned_word) = case platformWordSize platform of
-      PW4 -> ('W','w')
-      PW8 -> ('L','l')
diff --git a/compiler/GHC/HsToCore/Foreign/Prim.hs b/compiler/GHC/HsToCore/Foreign/Prim.hs
new file mode 100644
index 0000000000..888f2a1d6e
--- /dev/null
+++ b/compiler/GHC/HsToCore/Foreign/Prim.hs
@@ -0,0 +1,45 @@
+-- | Foreign primitive calls
+--
+-- This is for `@foreign import prim@' declarations.
+--
+-- Currently, at the core level we pretend that these primitive calls are
+-- foreign calls. It may make more sense in future to have them as a distinct
+-- kind of Id, or perhaps to bundle them with PrimOps since semantically and for
+-- calling convention they are really prim ops.
+module GHC.HsToCore.Foreign.Prim
+  ( dsPrimCall
+  )
+where
+
+import GHC.Prelude
+
+import GHC.Tc.Utils.Monad        -- temp
+import GHC.Tc.Utils.TcType
+
+import GHC.Core
+import GHC.Core.Type
+import GHC.Core.Coercion
+
+import GHC.HsToCore.Monad
+import GHC.HsToCore.Foreign.Call
+
+import GHC.Types.Id
+import GHC.Types.ForeignStubs
+import GHC.Types.ForeignCall
+
+dsPrimCall :: Id -> Coercion -> ForeignCall
+           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
+dsPrimCall fn_id co fcall = do
+    let
+        ty                   = coercionLKind co
+        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty
+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+
+    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
+
+    ccall_uniq <- newUnique
+    let
+        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
+        rhs      = mkLams tvs (mkLams args call_app)
+        rhs'     = Cast rhs co
+    return ([(fn_id, rhs')], mempty, mempty)
diff --git a/compiler/GHC/HsToCore/Foreign/Utils.hs b/compiler/GHC/HsToCore/Foreign/Utils.hs
new file mode 100644
index 0000000000..c632adabbe
--- /dev/null
+++ b/compiler/GHC/HsToCore/Foreign/Utils.hs
@@ -0,0 +1,76 @@
+module GHC.HsToCore.Foreign.Utils
+  ( Binding
+  , getPrimTyOf
+  , primTyDescChar
+  )
+where
+
+import GHC.Prelude
+
+import GHC.Platform
+
+import GHC.Tc.Utils.TcType
+
+import GHC.Core (CoreExpr)
+import GHC.Core.DataCon
+import GHC.Core.TyCon
+import GHC.Core.TyCo.Rep
+
+import GHC.Types.Id
+import GHC.Types.RepType
+
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
+
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain
+
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+                              -- the occurrence analyser will sort it all out
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).
+getPrimTyOf :: Type -> UnaryType
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitDataProductType_maybe rep_ty of
+     Just (_, _, data_con, [Scaled _ prim_ty]) ->
+        assert (dataConSourceArity data_con == 1) $
+        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
+          -- NB: it's OK to call isUnliftedType here, as we don't allow
+          -- representation-polymorphic types in foreign import/export declarations
+        prim_ty
+     _other -> pprPanic "getPrimTyOf" (ppr ty)
+  where
+        rep_ty = unwrapType ty
+
+-- represent a primitive type as a Char, for building a string that
+-- described the foreign function type.  The types are size-dependent,
+-- e.g. 'W' is a signed 32-bit integer.
+primTyDescChar :: Platform -> Type -> Char
+primTyDescChar !platform ty
+ | ty `eqType` unitTy = 'v'
+ | otherwise
+ = case typePrimRep1 (getPrimTyOf ty) of
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int8Rep     -> 'B'
+     Word8Rep    -> 'b'
+     Int16Rep    -> 'S'
+     Word16Rep   -> 's'
+     Int32Rep    -> 'W'
+     Word32Rep   -> 'w'
+     Int64Rep    -> 'L'
+     Word64Rep   -> 'l'
+     AddrRep     -> 'p'
+     FloatRep    -> 'f'
+     DoubleRep   -> 'd'
+     _           -> pprPanic "primTyDescChar" (ppr ty)
+  where
+    (signed_word, unsigned_word) = case platformWordSize platform of
+      PW4 -> ('W','w')
+      PW8 -> ('L','l')
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index de5450ed47..9e61e0e2a2 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -449,8 +449,11 @@ Library
         GHC.HsToCore.Errors.Ppr
         GHC.HsToCore.Errors.Types
         GHC.HsToCore.Expr
+        GHC.HsToCore.Foreign.C
         GHC.HsToCore.Foreign.Call
         GHC.HsToCore.Foreign.Decl
+        GHC.HsToCore.Foreign.Prim
+        GHC.HsToCore.Foreign.Utils
         GHC.HsToCore.GuardedRHSs
         GHC.HsToCore.ListComp
         GHC.HsToCore.Match