recursion-ninja pushed to branch wip/fix-26700 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/HsToCore/Foreign/C.hs
    ... ... @@ -93,14 +93,14 @@ dsCFExport fn_id co ext_name cconv target_kind = do
    93 93 
            -- If it's plain t, return      (t, ForeignValue)
    94 94 
            (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
    95 95 
                                     -- The function already returns IO t
    96 
    -                                Just (_ioTyCon, res_ty) -> (res_ty, ForeignFunction)
    96 
    +                                Just (_ioTyCon, res_ty) -> (res_ty, True)
    97 97 
                                     -- The function returns t
    98 
    -                                Nothing                 -> (orig_res_ty, ForeignValue)
    98 
    +                                Nothing                 -> (orig_res_ty, False)
    99 99
    100 100 
         dflags <- getDynFlags
    101 101 
         return $
    102 102 
           mkFExportCBits dflags ext_name
    103 
    -                     (if target_kind == ForeignFunction then Nothing else Just fn_id)
    103 
    +                     (if isDyn then Nothing else Just fn_id)
    104 104 
                          fe_arg_tys res_ty is_IO_res_ty cconv
    105 105
    106 106 
     dsCImport :: Id
    ... ... @@ -186,7 +186,7 @@ dsCFExportDynamic id co0 cconv = do
    186 186 
             export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
    187 187 
         bindIOId <- dsLookupGlobalId bindIOName
    188 188 
         stbl_value <- newSysLocalMDs stable_ptr_ty
    189 
    -    (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction
    189 
    +    (h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
    190 190 
         let
    191 191 
              {-
    192 192 
               The arguments to the external function which will
    ... ... @@ -279,7 +279,7 @@ dsFCall fn_id co fcall mDeclHeader = do
    279 279 
                             | isVoidRes =                   cCall
    280 280 
                             | otherwise = text "return" <+> cCall
    281 281 
                           cCall
    282 
    -                        | targetKind == ForeignFunction = ppr cName <> parens argVals
    282 
    +                        | ForeignFunction <- targetKind = ppr cName <> parens argVals
    283 283 
                             | null arg_tys = ppr cName
    284 284 
                             | otherwise = panic "dsFCall: Unexpected arguments to FFI value import"
    285 285 
                           raw_res_ty = case tcSplitIOType_maybe io_res_ty of

  • compiler/GHC/HsToCore/Foreign/Decl.hs
    ... ... @@ -93,7 +93,7 @@ dsForeigns' fos = do
    93 93 
                               , fd_e_ext = co
    94 94 
                               , fd_fe = CExport _
    95 95 
                                   (L _ (CExportStatic ext_nm cconv)) }) = do
    96 
    -      (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv ForeignValue
    96 
    +      (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False
    97 97 
           return (h, c, ids, bs)
    98 98
    99 99 
     {-
    ... ... @@ -165,8 +165,7 @@ dsFExport :: Id -- Either the exported Id,
    165 165 
                                     -- from C, and its representation type
    166 166 
               -> CLabelString       -- The name to export to C land
    167 167 
               -> CCallConv
    168 
    -          -> ForeignKind        -- If it is a function,
    169 
    -                                -- then is foreign export dynamic
    168 
    +          -> Bool               -- True => foreign export dynamic
    170 169 
                                     --         so invoke IO action that's hanging off
    171 170 
                                     --         the first argument's stable pointer
    172 171 
               -> DsM ( CHeader      -- contents of Module_stub.h
    ... ... @@ -175,16 +174,16 @@ dsFExport :: Id -- Either the exported Id,
    175 174 
                      , [Id]         -- function closures to be registered as GC roots
    176 175 
                      , [Binding]    -- additional bindings used by desugared foreign export
    177 176 
                      )
    178 
    -dsFExport fn_id co ext_name cconv target_kind = do
    177 
    +dsFExport fn_id co ext_name cconv is_dyn = do
    179 178 
       platform <- getPlatform
    180 179 
       case (platformArch platform, cconv) of
    181 180 
         (ArchJavaScript, _) -> do
    182 
    -      (h, c, ts) <- dsJsFExport fn_id co ext_name cconv target_kind
    181 
    +      (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn
    183 182 
           pure (h, c, ts, [fn_id], [])
    184 183 
         (ArchWasm32, JavaScriptCallConv) ->
    185 184 
           dsWasmJSExport fn_id co ext_name
    186 185 
         _ -> do
    187 
    -      (h, c, ts) <- dsCFExport fn_id co ext_name cconv target_kind
    186 
    +      (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn
    188 187 
           pure (h, c, ts, [fn_id], [])
    189 188
    190 189

  • compiler/GHC/HsToCore/Foreign/JavaScript.hs
    ... ... @@ -72,8 +72,7 @@ dsJsFExport
    72 72 
                             -- from C, and its representation type
    73 73 
       -> CLabelString       -- The name to export to C land
    74 74 
       -> CCallConv
    75 
    -  -> ForeignKind        -- If it is a function,
    76 
    -                        -- then is foreign export dynamic
    75 
    +  -> Bool               -- True => foreign export dynamic
    77 76 
                             --         so invoke IO action that's hanging off
    78 77 
                             --         the first argument's stable pointer
    79 78 
       -> DsM ( CHeader      -- contents of Module_stub.h
    ... ... @@ -81,7 +80,7 @@ dsJsFExport
    81 80 
              , String       -- string describing type to pass to createAdj.
    82 81 
              )
    83 82
    84 
    -dsJsFExport fn_id co ext_name cconv target_kind = do
    83 
    +dsJsFExport fn_id co ext_name cconv isDyn = do
    85 84 
         let
    86 85 
            ty                              = coercionRKind co
    87 86 
            (_tvs,sans_foralls)             = tcSplitForAllTyVars ty
    ... ... @@ -103,7 +102,7 @@ dsJsFExport fn_id co ext_name cconv target_kind = do
    103 102 
         platform <- targetPlatform <$> getDynFlags
    104 103 
         return $
    105 104 
           mkFExportJSBits platform ext_name
    106 
    -                     (if target_kind == ForeignFunction then Nothing else Just fn_id)
    105 
    +                     (if isDyn then Nothing else Just fn_id)
    107 106 
                          (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv
    108 107
    109 108 
     mkFExportJSBits
    ... ... @@ -284,7 +283,7 @@ dsJsFExportDynamic id co0 cconv = do
    284 283 
             export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
    285 284 
         bindIOId <- dsLookupGlobalId bindIOName
    286 285 
         stbl_value <- newSysLocalMDs stable_ptr_ty
    287 
    -    (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv ForeignFunction
    286 
    +    (h_code, c_code, typestring) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
    288 287 
         let
    289 288 
              {-
    290 289 
               The arguments to the external function which will

  • compiler/GHC/Types/ForeignCall.hs
    ... ... @@ -244,19 +244,6 @@ instance NFData ForeignCall where
    244 244 
     instance forall p. IsPass p => NFData (CCallSpec (GhcPass p)) where
    245 245 
       rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s
    246 246
    247 
    --- TODO: The orphan instance should be moved to the 'GHC.Utils.Binary' module and
    248 
    --- and the 'GHC.Utils.Outputable' module after the 'Language.Haskell.Syntax.Decls'
    249 
    --- module no longer imports 'GHC.Hs.Doc'.
    250 
    ---
    251 
    --- Instances for the following types eventually need to be relocated:
    252 
    ---
    253 
    ---  * CCallConv
    254 
    ---  * CCallTarget
    255 
    ---  * CExportSpec
    256 
    ---  * CType
    257 
    ---  * Header
    258 
    ---  * Safety
    259 
    ---
    260 247 
     instance Binary CCallConv where
    261 248 
         put_ bh CCallConv =
    262 249 
                 putByte bh 0
    ... ... @@ -280,8 +267,9 @@ instance Binary CCallConv where
    280 267 
     -- If Nothing, then it's taken to be in the current package.
    281 268 
     data StaticTargetGhc = StaticTargetGhc
    282 269 
       { staticTargetLabel :: SourceText
    283 
    -  , staticTargetUnit  :: Unit
    270 
    +  , staticTargetUnit  :: CCallStaticUnit
    284 271 
           -- ^ What package the function is in.
    272 
    +      -- If 'CCallStaticThisUnit', then it's taken to be in the current package
    285 273 
           -- Note: This information is only used for PrimCalls on Windows.
    286 274 
           --       See CLabel.labelDynamic and CoreToStg.coreToStgApp
    287 275 
           --       for the difference in representation between PrimCalls
    ... ... @@ -305,7 +293,7 @@ type instance XXCCallTarget (GhcPass p) = DataConCantHappen
    305 293 
     type instance XCType  (GhcPass p) = CTypeGhc
    306 294 
     type instance XXCType (GhcPass p) = DataConCantHappen
    307 295
    308 
    -instance {-# OVERLAPPING #-} NFData (CType (GhcPass p)) where
    296 
    +instance NFData (CType (GhcPass p)) where
    309 297 
         rnf (CType ext mh fs) =
    310 298 
           rnf ext `seq` rnf mh `seq` rnf fs
    311 299
    ... ... @@ -344,7 +332,7 @@ instance Binary StaticTargetGhc where
    344 332 
             , staticTargetUnit  = unit
    345 333 
             }
    346 334
    347 
    -instance {-# OVERLAPPING #-} forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
    335 
    +instance forall p. IsPass p => Eq (CCallTarget (GhcPass p)) where
    348 336 
         (==) = \case
    349 337 
           DynamicTarget{} -> \case
    350 338 
             DynamicTarget{} -> True

  • compiler/Language/Haskell/Syntax/Decls/Foreign.hs
    ... ... @@ -201,12 +201,10 @@ data CCallTarget pass
    201 201 
       = StaticTarget
    202 202 
             (XStaticTarget pass)
    203 203 
             CLabelString -- C-land name of label.
    204 
    -                     --    Used when importing a label as "foreign import ccall "dynamic" ..."
    205 
    -        ForeignKind  -- True => really a function
    206 
    -                     -- False => a value; only
    207 
    -                     -- allowed in CAPI imports
    204 
    +        ForeignKind  -- only allowed in CAPI imports
    208 205
    209 
    -  -- The first argument of the import is the name of a function pointer (an Addr#).
    206 
    +  -- | The first argument of the import is the name of a function pointer (an Addr#).
    207 
    +  -- Used when importing a label as "foreign import ccall "dynamic" ..."
    210 208 
       | DynamicTarget (XDynamicTarget pass)
    211 209 
       | XCCallTarget !(XXCCallTarget pass)
    212 210
    ... ... @@ -216,8 +214,8 @@ deriving instance {-# OVERLAPPABLE #-} (
    216 214 
       Eq (XXCCallTarget  pass)) =>
    217 215 
         Eq (CCallTarget pass)
    218 216
    219 
    --- foreign export ccall foo :: ty
    220 217 
     data CExportSpec
    218 
    +  -- | foreign export ccall foo :: ty
    221 219 
       = CExportStatic
    222 220 
             CLabelString -- C Name of exported function
    223 221 
             CCallConv

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help