Duncan Coutts pushed to branch wip/dcoutts/foreign-label-source-refactoring at Glasgow Haskell Compiler / GHC

Commits:

22 changed files:

Changes:

  • compiler/GHC/Builtin/PrimOps.hs
    ... ... @@ -50,7 +50,7 @@ import GHC.Types.SrcLoc ( wiredInSrcSpan )
    50 50 
     import GHC.Types.ForeignCall ( CLabelString )
    51 51 
     import GHC.Types.Unique  ( Unique )
    52 52
    53 
    -import GHC.Unit.Types    ( Unit )
    53 
    +import GHC.Unit.Types    ( UnitId )
    54 54
    55 55 
     import GHC.Utils.Binary
    56 56 
     import GHC.Utils.Outputable
    ... ... @@ -929,11 +929,11 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op)
    929 929 
     ************************************************************************
    930 930 
     -}
    931 931
    932 
    -data PrimCall = PrimCall CLabelString Unit
    932 
    +data PrimCall = PrimCall CLabelString UnitId
    933 933
    934 934 
     instance Outputable PrimCall where
    935 
    -  ppr (PrimCall lbl pkgId)
    936 
    -        = text "__primcall" <+> ppr pkgId <+> ppr lbl
    935 
    +  ppr (PrimCall lbl unitId)
    936 
    +        = text "__primcall" <+> ppr unitId <+> ppr lbl
    937 937
    938 938 
     -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it
    939 939 
     -- isn't DataToTagOp which are two primops that evaluate their argument

  • compiler/GHC/ByteCode/Asm.hs
    ... ... @@ -868,7 +868,7 @@ assembleI platform i = case i of
    868 868 
         emit_ = emit word_size
    869 869
    870 870 
         literal :: Literal -> m Word
    871 
    -    literal (LitLabel fs _)   = litlabel fs
    871 
    +    literal (LitLabel lbl)    = litlabel lbl
    872 872 
         literal LitNullAddr       = word 0
    873 873 
         literal (LitFloating LitFloat  x) = float  (litFloatingToHostFloat  x)
    874 874 
         literal (LitFloating LitDouble x) = double (litFloatingToHostDouble x)
    ... ... @@ -893,7 +893,7 @@ assembleI platform i = case i of
    893 893 
         -- analysis messed up.
    894 894 
         literal (LitRubbish {}) = word 0
    895 895
    896 
    -    litlabel fs = lit1 (BCONPtrLbl fs)
    896 
    +    litlabel (CLabelSpec fs _ _) = lit1 (BCONPtrLbl fs)
    897 897 
         words ws = lit (fmap BCONPtrWord ws)
    898 898 
         word w = words (OnlyOne w)
    899 899 
         word2 w1 w2 = words (OnlyTwo w1 w2)

  • compiler/GHC/Cmm/CLabel.hs
    ... ... @@ -115,6 +115,7 @@ module GHC.Cmm.CLabel (
    115 115 
             hasIdLabelInfo,
    116 116 
             isBytesLabel,
    117 117 
             isForeignLabel,
    118 
    +        isForeignLabelUnknownPackage,
    118 119 
             isSomeRODataLabel,
    119 120 
             isStaticClosureLabel,
    120 121
    ... ... @@ -448,8 +449,32 @@ data ForeignLabelSource
    448 449 
        --   contain compiled Haskell code, and is not associated with any .hi files.
    449 450 
        --   We don't have to worry about Haskell code being inlined from
    450 451 
        --   external packages. It is safe to treat the RTS package as "external".
    452 
    +   --
    453 
    +   --   On Windows in particular, we assume the label is definately in an
    454 
    +   --   external DLL and expect to link it against a __imp_* symbol. Thus it
    455 
    +   --   will /not/ link correctly if the symbol is actually in the same DLL.
    451 456 
        | ForeignLabelInExternalPackage
    452 457
    458 
    +   -- | The label is somewhere, but we do not know if it is in this package or
    459 
    +   --   an external package. This is the case we end up with for Haskell FFI
    460 
    +   --   declarations like @foreign import ccall@. There is not enough
    461 
    +   --   information to tell us if the label is from the same package (e.g. in
    462 
    +   --   a local @cbits/blah.c@ file) or is from an external foreign library.
    463 
    +   --
    464 
    +   --   On ELF, this is not a problem and the symbol can be resolved without
    465 
    +   --   knowing if its local or external.
    466 
    +   --
    467 
    +   --   On Windows/PE, this is a bit of a problem. On Windows one normally
    468 
    +   --   needs to know if it's local or external since the symbol names and
    469 
    +   --   ABI differ. However, GCC & LLVM have extensions to help porting Unix
    470 
    +   --   software (that is not used to making these distinctions). There are a
    471 
    +   --   number of useful mechanisms including \"auto import\" (to import
    472 
    +   --   symbols found in DLLs automatically), a @.refptr@ mechanism to load
    473 
    +   --   data via an indirection (which the linker can relocate) and
    474 
    +   --   \"pseudo relocations\" which is a runtime feature to do additional
    475 
    +   --   relocations beyond what the Win32 native linker does.
    476 
    +   | ForeignLabelInUnknownPackage
    477 
    +
    453 478 
        -- | Label is in the package currently being compiled.
    454 479 
        --   This is only used for creating hacky tmp labels during code generation.
    455 480 
        --   Don't use it in any code that might be inlined across a package boundary
    ... ... @@ -477,8 +502,8 @@ data ForeignLabelSource
    477 502 
     --    from, e.g. the RTS, which then fall into the 'CLabelTargetInUnit' case.
    478 503 
     --
    479 504 
     toForeignLabelSource :: CLabelTargetLibrary -> ForeignLabelSource
    480 
    -toForeignLabelSource (CLabelTargetInUnit unit) = ForeignLabelInPackage
    481 
    -                                                   (toUnitId unit)
    505 
    +toForeignLabelSource CLabelTargetUnknown       = ForeignLabelInUnknownPackage
    506 
    +toForeignLabelSource (CLabelTargetInUnit unit) = ForeignLabelInPackage unit
    482 507
    483 508
    484 509 
     -- | For debugging problems with the CLabel representation.
    ... ... @@ -774,8 +799,8 @@ mkApEntryLabel platform upd arity =
    774 799
    775 800 
     -- A call to some primitive hand written Cmm code
    776 801 
     mkPrimCallLabel :: PrimCall -> CLabel
    777 
    -mkPrimCallLabel (PrimCall str pkg)
    778 
    -        = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall
    802 
    +mkPrimCallLabel (PrimCall str unitid)
    803 
    +        = CmmLabel unitid (NeedExternDecl True) str CmmPrimCall
    779 804
    780 805
    781 806 
     -- Constructing ForeignLabels
    ... ... @@ -799,6 +824,10 @@ isForeignLabel :: CLabel -> Bool
    799 824 
     isForeignLabel (ForeignLabel _ _ _) = True
    800 825 
     isForeignLabel _lbl = False
    801 826
    827 
    +isForeignLabelUnknownPackage :: CLabel -> Bool
    828 
    +isForeignLabelUnknownPackage (ForeignLabel _ ForeignLabelInUnknownPackage _) = True
    829 
    +isForeignLabelUnknownPackage _lbl = False
    830 
    +
    802 831 
     -- | Whether label is a static closure label (can come from haskell or cmm)
    803 832 
     isStaticClosureLabel :: CLabel -> Bool
    804 833 
     -- Closure defined in haskell (.hs)
    ... ... @@ -1329,9 +1358,9 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
    1329 1358
    1330 1359 
        LocalBlockLabel _    -> False
    1331 1360
    1332 
    -   ForeignLabel _ source _  ->
    1333 
    -       if os == OSMinGW32
    1334 
    -       then case source of
    1361 
    +   ForeignLabel _ source _
    1362 
    +     | os == OSMinGW32 ->
    1363 
    +          case source of
    1335 1364 
                 -- Foreign label is in some un-named foreign package (or DLL).
    1336 1365 
                 ForeignLabelInExternalPackage -> True
    1337 1366
    ... ... @@ -1339,16 +1368,22 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
    1339 1368 
                 -- source file currently being compiled.
    1340 1369 
                 ForeignLabelInThisPackage -> False
    1341 1370
    1371 
    +            -- Foreign label is either in the same package or is in some
    1372 
    +            -- foreign package/DLL/DSO. Neither yes nor no is the correct
    1373 
    +            -- answer here, because on Windows these are a distinct case
    1374 
    +            -- that need special treatment in the code generator.
    1375 
    +            ForeignLabelInUnknownPackage -> True
    1376 
    +
    1342 1377 
                 -- Foreign label is in some named package.
    1343 1378 
                 -- When compiling in the "dyn" way, each package is to be
    1344 1379 
                 -- linked into its own DLL.
    1345 1380 
                 ForeignLabelInPackage pkgId ->
    1346 1381 
                     external_dynamic_refs && (this_unit /= pkgId)
    1347 1382
    1348 
    -       else -- On Mac OS X and on ELF platforms, false positives are OK,
    1349 
    -            -- so we claim that all foreign imports come from dynamic
    1350 
    -            -- libraries
    1351 
    -            True
    1383 
    +       -- On Mac OS X and on ELF platforms, false positives are OK,
    1384 
    +       -- so we claim that all foreign imports come from dynamic
    1385 
    +       -- libraries
    1386 
    +     | otherwise -> True
    1352 1387
    1353 1388 
        CC_Label cc ->
    1354 1389 
          external_dynamic_refs && not (ccFromThisModule cc this_mod)
    ... ... @@ -1699,6 +1734,7 @@ instance Outputable ForeignLabelSource where
    1699 1734 
             ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId
    1700 1735 
             ForeignLabelInThisPackage       -> parens $ text "this package"
    1701 1736 
             ForeignLabelInExternalPackage   -> parens $ text "external package"
    1737 
    +        ForeignLabelInUnknownPackage    -> parens $ text "unknown package"
    1702 1738
    1703 1739 
     -- -----------------------------------------------------------------------------
    1704 1740 
     -- Machine-dependent knowledge about labels.

  • compiler/GHC/HsToCore/Foreign/C.hs
    ... ... @@ -116,7 +116,7 @@ dsCImport id co (CLabel cid) _ _ _ = do
    116 116 
        (resTy, foRhs) <- resultWrapper ty
    117 117 
        assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
    118 118 
         let
    119 
    -        rhs = foRhs (Lit (LitLabel cid fod))
    119 
    +        rhs = foRhs (Lit (LitLabel (CLabelSpec cid fod CLabelTargetUnknown)))
    120 120 
             rhs' = Cast rhs co
    121 121 
         in
    122 122 
         return ([(id, rhs')], mempty, mempty)
    ... ... @@ -191,8 +191,10 @@ dsCFExportDynamic id co0 cconv = do
    191 191 
               to be entered using an external calling convention
    192 192 
               (ccall).
    193 193 
              -}
    194 
    +        fe_lbl        = CLabelSpec fe_nm ForeignLabelIsFunction
    195 
    +                                   (CLabelTargetInUnit (moduleUnitId mod))
    194 196 
             adj_args      = [ Var stbl_value
    195 
    -                        , Lit (LitLabel fe_nm ForeignLabelIsFunction)
    197 
    +                        , Lit (LitLabel fe_lbl)
    196 198 
                             , Lit (mkLitString typestring)
    197 199 
                             ]
    198 200 
               -- name of external entry point providing these services.
    ... ... @@ -200,7 +202,7 @@ dsCFExportDynamic id co0 cconv = do
    200 202 
             adjustor   = CCallSpec
    201 203 
                            (StaticTarget
    202 204 
                              (StaticTargetGhc NoSourceText
    203 
    -                                          (CLabelTargetInUnit rtsUnit))
    205 
    +                                          (CLabelTargetInUnit rtsUnitId))
    204 206 
                              (fsLit "createAdjustor")
    205 207 
                              ForeignFunction)
    206 208 
                            CCallConv
    ... ... @@ -263,15 +265,19 @@ dsFCall fn_id co fcall mDeclHeader = do
    263 265
    264 266 
         (fcall', cDoc) <-
    265 267 
                   case fcall of
    266 
    -              CCall (CCallSpec (StaticTarget stExt cName targetKind)
    268 
    +              CCall (CCallSpec (StaticTarget _ cName targetKind)
    267 269 
                                    CApiConv safety) ->
    268 270 
                    do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
    269 271 
                       wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
    270 
    -                  let fcall' = CCall (CCallSpec
    271 
    -                                      (StaticTarget (stExt { staticTargetLabel = NoSourceText} )
    272 
    -                                                    wrapperName
    273 
    -                                                    ForeignFunction)
    274 
    -                                      CApiConv safety)
    272 
    +                  mod <- getModule
    273 
    +                  let thisUnit = moduleUnitId mod
    274 
    +                      -- the C wrapper function is linked into this unit (shared lib)
    275 
    +                      wrapperTarget = StaticTarget (StaticTargetGhc
    276 
    +                                                      NoSourceText
    277 
    +                                                      (CLabelTargetInUnit thisUnit))
    278 
    +                                                   wrapperName
    279 
    +                                                   ForeignFunction
    280 
    +                      fcall' = CCall (CCallSpec wrapperTarget CApiConv safety)
    275 281 
                           c = includes
    276 282 
                            $$ fun_proto <+> braces (cRet <> semi)
    277 283 
                           includes = vcat [ text "#include \"" <> ftext h

  • compiler/GHC/HsToCore/Foreign/JavaScript.hs
    ... ... @@ -240,7 +240,7 @@ dsJsImport id co (CLabel cid) _ _ _ = do
    240 240 
                  _ -> ForeignLabelIsData
    241 241 
        (_resTy, foRhs) <- jsResultWrapper ty
    242 242 
     --   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
    243 
    -   let rhs = foRhs (Lit (LitLabel cid fod))
    243 
    +   let rhs = foRhs (Lit (LitLabel (CLabelSpec cid fod CLabelTargetUnknown)))
    244 244 
            rhs' = Cast rhs co
    245 245
    246 246 
        return ([(id, rhs')], mempty, mempty)
    ... ... @@ -290,8 +290,10 @@ dsJsFExportDynamic id co0 cconv = do
    290 290 
               to be entered using an external calling convention
    291 291 
               (ccall).
    292 292 
              -}
    293 
    +        fe_lbl        = CLabelSpec fe_nm ForeignLabelIsFunction
    294 
    +                                   (CLabelTargetInUnit (moduleUnitId mod))
    293 295 
             adj_args      = [ Var stbl_value
    294 
    -                        , Lit (LitLabel fe_nm ForeignLabelIsFunction)
    296 
    +                        , Lit (LitLabel fe_lbl)
    295 297 
                             , Lit (mkLitString typestring)
    296 298 
                             ]
    297 299 
               -- name of external entry point providing these services.
    ... ... @@ -299,7 +301,7 @@ dsJsFExportDynamic id co0 cconv = do
    299 301 
             adjustor   = CCallSpec
    300 302 
                            (StaticTarget
    301 303 
                              (StaticTargetGhc NoSourceText
    302 
    -                                          (CLabelTargetInUnit rtsUnit))
    304 
    +                                          (CLabelTargetInUnit rtsUnitId))
    303 305 
                              (fsLit "createAdjustor")
    304 306 
                              ForeignFunction)
    305 307 
                            CCallConv
    ... ... @@ -655,7 +657,7 @@ mkJsCall u tgt args t = mkFCall u ccall args t
    655 657 
       where
    656 658 
         stExt = StaticTargetGhc
    657 659 
             { staticTargetLabel = NoSourceText
    658 
    -        , staticTargetUnit  = CLabelTargetInUnit ghcInternalUnit
    660 
    +        , staticTargetUnit  = CLabelTargetInUnit ghcInternalUnitId
    659 661 
             }
    660 662 
         ccall = CCall $ CCallSpec
    661 663 
                   (StaticTarget stExt tgt ForeignFunction)

  • compiler/GHC/Parser/PostProcess.hs
    ... ... @@ -3136,7 +3136,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td)
    3136 3136 
               then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport
    3137 3137 
               else returnSpec imp
    3138 3138 
           StdCallConv        -> returnSpec =<< mkCImport
    3139 
    -      PrimCallConv       -> mkOtherImport
    3139 
    +      PrimCallConv       -> returnSpec =<< mkPrimImport
    3140 3140 
           JavaScriptCallConv -> mkOtherImport
    3141 3141 
       where
    3142 3142 
         -- Parse a C-like entity string of the following form:
    ... ... @@ -3145,7 +3145,9 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td)
    3145 3145 
         -- name (cf section 8.5.1 in Haskell 2010 report).
    3146 3146 
         mkCImport = do
    3147 3147 
           let e = unpackFS entity
    3148 
    -      case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of
    3148 
    +      case parseCImport (reLoc cconv) (reLoc safety)
    3149 
    +                        (mkExtName (unLoc v))
    3150 
    +                        e (L loc esrc) of
    3149 3151 
             Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $
    3150 3152 
                                  PsErrMalformedEntityString
    3151 3153 
             Just importSpec -> return importSpec
    ... ... @@ -3153,6 +3155,15 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td)
    3153 3155 
         isCWrapperImport (CImport _ _ _ _ CWrapper) = True
    3154 3156 
         isCWrapperImport _ = False
    3155 3157
    3158 
    +    mkPrimImport = do
    3159 
    +      let e = unpackFS entity
    3160 
    +      case parsePrimImport (reLoc cconv) (reLoc safety)
    3161 
    +                           (mkExtName (unLoc v))
    3162 
    +                           e (L loc esrc) of
    3163 
    +        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $
    3164 
    +                             PsErrMalformedEntityString
    3165 
    +        Just importSpec -> return importSpec
    3166 
    +
    3156 3167 
         -- currently, all the other import conventions only support a symbol name in
    3157 3168 
         -- the entity string. If it is missing, we use the function name instead.
    3158 3169 
         mkOtherImport = returnSpec importSpec
    ... ... @@ -3230,6 +3241,49 @@ parseCImport cconv safety nm str sourceText =
    3230 3241 
                           cs <-  many (satisfy id_char)
    3231 3242 
                           return (mkFastString (c:cs)))
    3232 3243
    3244 
    +-- Parse a Cmm name entity string of the following form:
    3245 
    +--   "[pkgname] cmmid"
    3246 
    +-- If 'cmmid' is missing, the function name 'v' is used instead as symbol
    3247 
    +-- name (cf section 8.5.1 in Haskell 2010 report).
    3248 
    +
    3249 
    +-- Note: the PackageName is stashed in the Header field. It gets pulled out
    3250 
    +-- in the renamer, see rnHsForeignImport case for PrimCallConv. It would be
    3251 
    +-- nicer if the ForeignImport representation had a case for each calling
    3252 
    +-- convention. See issue #27209.
    3253 
    +--
    3254 
    +parsePrimImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
    3255 
    +                -> Located SourceText
    3256 
    +                -> Maybe (ForeignImport GhcPs)
    3257 
    +parsePrimImport cconv safety nm str sourceText =
    3258 
    +    listToMaybe $ map fst $ filter (null.snd) $
    3259 
    +      readP_to_S parse str
    3260 
    +  where
    3261 
    +    parse = do
    3262 
    +       skipSpaces
    3263 
    +       pkgname <- return Nothing
    3264 
    +              +++ (do pkgname <- parse_pkgname
    3265 
    +                      skipSpaces
    3266 
    +                      return (Just (Header NoSourceText pkgname)))
    3267 
    +       cmmid  <- return nm +++ parse_cmmid
    3268 
    +       skipSpaces
    3269 
    +       let !cfun = CFunction (StaticTarget NoSourceText cmmid ForeignFunction)
    3270 
    +           !cimp = CImport (reLoc sourceText) (reLoc cconv)
    3271 
    +                           (reLoc safety) pkgname cfun
    3272 
    +       return cimp
    3273 
    +
    3274 
    +    parse_cmmid = mkFastString <$>
    3275 
    +                    ((:) <$> satisfy cmmid_first_char
    3276 
    +                         <*> many (satisfy cmmid_char))
    3277 
    +
    3278 
    +    parse_pkgname = do str <- many1 (satisfy pkgname_char)
    3279 
    +                       if looksLikePackageName str
    3280 
    +                         then return (mkFastString str)
    3281 
    +                         else fail "invalid package name syntax"
    3282 
    +
    3283 
    +    cmmid_first_char c = isAlpha    c || c == '_'
    3284 
    +    cmmid_char       c = isAlphaNum c || c == '_'
    3285 
    +
    3286 
    +    pkgname_char     c = isAlphaNum c || c == '_' || c == '-'
    3233 3287
    3234 3288 
     -- construct a foreign export declaration
    3235 3289 
     --

  • compiler/GHC/Rename/Module.hs
    ... ... @@ -61,7 +61,7 @@ import GHC.Types.Unique.Set
    61 61 
     import GHC.Types.SrcLoc as SrcLoc
    62 62
    63 63 
     import GHC.Driver.DynFlags
    64 
    -import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
    64 
    +import GHC.Driver.Env ( HscEnv(..), hsc_home_unit, hsc_units )
    65 65
    66 66 
     import GHC.Utils.Misc   ( lengthExceeds )
    67 67 
     import GHC.Utils.Panic
    ... ... @@ -393,14 +393,9 @@ rnDefaultDecl (DefaultDecl _ mb_cls tys)
    393 393
    394 394 
     rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeNames)
    395 395 
     rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
    396 
    -  = do { topEnv :: HscEnv <- getTopEnv
    397 
    -       ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name
    396 
    +  = do { name' <- lookupLocatedTopBndrRnN WL_TermVariable name
    398 397 
            ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
    399 
    -
    400 
    -        -- Mark any PackageTarget style imports as coming from the current package
    401 
    -       ; let home_unit = hsc_home_unit topEnv
    402 
    -             spec'  = patchForeignImport (homeUnitAsUnit home_unit) spec
    403 
    -
    398 
    +       ; spec' <- rnHsForeignImport spec
    404 399 
            ; return (ForeignImport { fd_i_ext = noExtField
    405 400 
                                    , fd_name = name', fd_sig_ty = ty'
    406 401 
                                    , fd_fi = spec' }, fvs) }
    ... ... @@ -416,28 +411,62 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
    416 411 
             --     we add it to the free-variable list.  It might, for example,
    417 412 
             --     be imported from another module
    418 413
    419 
    --- | For Windows DLLs we need to know what packages imported symbols are from
    420 
    ---      to generate correct calls. Imported symbols are tagged with the current
    421 
    ---      package, so if they get inlined across a package boundary we'll still
    422 
    ---      know where they're from.
    423 
    ---
    424 
    -patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)
    425 
    -patchForeignImport unit (CImport ext cconv safety fs spec)
    426 
    -        = CImport ext cconv safety (renameHeader <$> fs) (patchCImportSpec unit spec)
    414 
    +rnHsForeignImport :: ForeignImport GhcPs -> RnM (ForeignImport GhcRn)
    427 415
    428 
    -patchCImportSpec :: Unit -> CImportSpec GhcPs -> CImportSpec GhcRn
    429 
    -patchCImportSpec unit = \case
    430 
    -    CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget
    416 
    +-- | Rename 'foreign import prim "[pkgname] cmmid"': the (optional) package name
    417 
    +-- is used to specify in which unit the cmm primitive lives. Resolve the
    418 
    +-- package name to a unit. If the package name is not specified, it means the
    419 
    +-- target lives in the current unit.
    420 
    +--
    421 
    +-- Note: the PackageName is stashed in the Header field in parsePrimImport.
    422 
    +-- It gets pulled out below in the rnHsForeignImport case for PrimCallConv.
    423 
    +-- It would be nicer if the ForeignImport representation had a case for each
    424 
    +-- calling convention. See issue #27209.
    425 
    +--
    426 
    +-- The typical use cases are:
    427 
    +--  * cmm primops defined in the rts but bound in a library like ghc-internal
    428 
    +--    e.g. foreign import prim "rts blah"
    429 
    +--  * cmm primops defined in a local .cmm file in the same library.
    430 
    +--
    431 
    +rnHsForeignImport (CImport ext cconv@(L _ PrimCallConv) safety header spec)
    432 
    +  = do { topEnv :: HscEnv <- getTopEnv
    433 
    +       ; target <- getPrimTargetUnit topEnv header
    434 
    +       ; return (CImport ext cconv safety Nothing
    435 
    +                         (renameCImportSpec target spec))
    436 
    +       }
    437 
    +  where
    438 
    +    getPrimTargetUnit topEnv Nothing =
    439 
    +        let this = homeUnitId (hsc_home_unit topEnv) in
    440 
    +        return (CLabelTargetInUnit this)
    441 
    +
    442 
    +    getPrimTargetUnit topEnv (Just (Header _ fs)) =
    443 
    +        let pkgname = PackageName fs in
    444 
    +        case lookupPackageName (hsc_units topEnv) pkgname of
    445 
    +            Just that ->
    446 
    +                return (CLabelTargetInUnit that)
    447 
    +            Nothing   -> do
    448 
    +                addErrAt (locA ext) (TcRnUnknownPrimCallPackageName pkgname)
    449 
    +                let this = homeUnitId (hsc_home_unit topEnv)
    450 
    +                return (CLabelTargetInUnit this)
    451 
    +
    452 
    +rnHsForeignImport (CImport ext cconv safety header spec)
    453 
    +  = return (CImport ext cconv safety
    454 
    +                    (renameHeader <$> header)
    455 
    +                    (renameCImportSpec CLabelTargetUnknown spec))
    456 
    +
    457 
    +renameCImportSpec :: CLabelTargetLibrary -> CImportSpec GhcPs -> CImportSpec GhcRn
    458 
    +renameCImportSpec targetLib = \case
    459 
    +    CFunction callTarget -> CFunction $ renameCCallTarget targetLib callTarget
    431 460 
         CLabel    cLabel     -> CLabel cLabel
    432 461 
         CWrapper             -> CWrapper
    433 462
    434 
    -patchCCallTarget :: Unit -> CCallTarget GhcPs -> CCallTarget GhcRn
    435 
    -patchCCallTarget unit = \case
    463 
    +renameCCallTarget :: CLabelTargetLibrary -> CCallTarget GhcPs -> CCallTarget GhcRn
    464 
    +renameCCallTarget targetLib = \case
    436 465 
         DynamicTarget x -> DynamicTarget x
    437 466 
         StaticTarget sTxt label targetKind ->
    438 467 
           let ext = StaticTargetGhc
    439 468 
                 { staticTargetLabel = sTxt
    440 
    -            , staticTargetUnit  = CLabelTargetInUnit unit
    469 
    +            , staticTargetUnit  = targetLib
    441 470 
                 }
    442 471 
           in  StaticTarget ext label targetKind
    443 472

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -1909,7 +1909,9 @@ generatePrimCall d s p target _result_ty args
    1909 1909 
              prim_args_offsets = mapFst stgArgRepU args_offsets
    1910 1910 
              shifted_args_offsets = mapSnd (+ d) args_offsets
    1911 1911
    1912 
    -         push_target = PUSH_UBX (LitLabel target ForeignLabelIsFunction) 1
    1912 
    +         labelspec = CLabelSpec target ForeignLabelIsFunction
    1913 
    +                                       CLabelTargetUnknown
    1914 
    +         push_target = PUSH_UBX (LitLabel labelspec) 1
    1913 1915 
              push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1
    1914 1916 
              {-
    1915 1917 
                 compute size to move payload (without stg_primcall_info header)
    ... ... @@ -2062,7 +2064,8 @@ generateCCall d0 s p (CCallSpec target _ safety) result_ty args
    2062 2064 
                      StaticTarget _ _ ForeignValue ->
    2063 2065 
                        panic "generateCCall: unexpected FFI value import"
    2064 2066 
                      StaticTarget _ target ForeignFunction ->
    2065 
    -                   Just (LitLabel target ForeignLabelIsFunction)
    2067 
    +                   Just (LitLabel (CLabelSpec target ForeignLabelIsFunction
    2068 
    +                                              CLabelTargetUnknown))
    2066 2069
    2067 2070 
          let
    2068 2071 
              is_static = isJust maybe_static_target

  • compiler/GHC/StgToCmm/Lit.hs
    ... ... @@ -94,8 +94,7 @@ mkSimpleLit platform = \case
    94 94 
        (LitNumber LitNumWord32 i)   -> CmmInt i W32
    95 95 
        (LitNumber LitNumWord64 i)   -> CmmInt i W64
    96 96 
        (LitFloating fty r)          -> CmmFloat r fty
    97 
    -   (LitLabel fs fod)
    98 
    -     -> let -- TODO: Literal labels might not actually be in the current package...
    99 
    -            labelSrc = ForeignLabelInThisPackage
    100 
    -        in CmmLabel (mkForeignLabel fs labelSrc fod)
    101 
    -   other -> pprPanic "mkSimpleLit" (ppr other)
    97 
    +   (LitLabel
    98 
    +      (CLabelSpec lbl fod tgt)) -> CmmLabel (mkForeignLabel lbl lblsrc fod)
    99 
    +                                     where lblsrc = toForeignLabelSource tgt
    100 
    +   other                        -> pprPanic "mkSimpleLit" (ppr other)

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -36,7 +36,7 @@ import GHC.Cmm.BlockId
    36 36 
     import GHC.Cmm.Graph
    37 37 
     import GHC.Stg.Syntax
    38 38 
     import GHC.Cmm
    39 
    -import GHC.Unit         ( rtsUnit )
    39 
    +import GHC.Unit         ( rtsUnitId )
    40 40 
     import GHC.Core.Type    ( Type, tyConAppTyCon_maybe )
    41 41 
     import GHC.Core.TyCon
    42 42 
     import GHC.Cmm.CLabel
    ... ... @@ -3842,7 +3842,7 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n =
    3842 3842 
             emit graph
    3843 3843 
       where
    3844 3844 
         lbl = mkLblExpr $ mkPrimCallLabel
    3845 
    -          $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit
    3845 
    +          $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnitId
    3846 3846 
         args =
    3847 3847 
           [ mkIntExpr platform hdr_size
    3848 3848 
           , dst

  • compiler/GHC/StgToJS/Literal.hs
    ... ... @@ -61,12 +61,12 @@ genLit = \case
    61 61 
         LitNumBigNat  -> panic "genLit: unexpected BigNat that should have been removed in CorePrep"
    62 62 
       LitFloating LitFloat r     -> return [ toJExpr (float2Double $ litFloatingToHostFloat r) ]
    63 63 
       LitFloating LitDouble r    -> return [ toJExpr (litFloatingToHostDouble r) ]
    64 
    -  LitLabel name ForeignLabelIsFunction
    64 
    +  LitLabel (CLabelSpec name ForeignLabelIsFunction _)
    65 65 
                                  -> return [ ApplExpr hdMkFunctionPtr
    66 66 
                                                       [global (mkRawSymbol True name)]
    67 67 
                                            , ValExpr (JInt 0)
    68 68 
                                            ]
    69 
    -  LitLabel name ForeignLabelIsData
    69 
    +  LitLabel (CLabelSpec name ForeignLabelIsData _)
    70 70 
                                  -> return [ toJExpr (global (mkRawSymbol True name))
    71 71 
                                            , ValExpr (JInt 0)
    72 72 
                                            ]
    ... ... @@ -115,8 +115,10 @@ genStaticLit = \case
    115 115 
         LitNumBigNat  -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep"
    116 116 
       LitFloating LitFloat r   -> return [ DoubleLit . SaneDouble $ float2Double $ litFloatingToHostFloat r ]
    117 117 
       LitFloating LitDouble r  -> return [ DoubleLit . SaneDouble $ litFloatingToHostDouble r ]
    118 
    -  LitLabel name fod        -> return [ LabelLit (fod == ForeignLabelIsFunction) (mkRawSymbol True name)
    119 
    -                                     , IntLit 0 ]
    118 
    +  LitLabel (CLabelSpec name fod _)
    119 
    +                  -> return [ LabelLit (fod == ForeignLabelIsFunction)
    120 
    +                                       (mkRawSymbol True name)
    121 
    +                            , IntLit 0 ]
    120 122 
       LitRubbish _ rep ->
    121 123 
         let prim_reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genStaticLit") rep
    122 124 
         in case expectOnly prim_reps of -- Note [Post-unarisation invariants]

  • compiler/GHC/Tc/Errors/Ppr.hs
    ... ... @@ -2060,6 +2060,9 @@ instance Diagnostic TcRnMessage where
    2060 2060 
         TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $
    2061 2061 
           text "Unexpected" <+> pprTypeSyntaxName syntax
    2062 2062
    2063 
    +    TcRnUnknownPrimCallPackageName pkgname -> mkSimpleDecorated $
    2064 
    +      text "Unknown source package" <+> quotes (ppr pkgname) <+> "in foreign import prim."
    2065 
    +
    2063 2066 
       diagnosticReason :: TcRnMessage -> DiagnosticReason
    2064 2067 
       diagnosticReason = \case
    2065 2068 
         TcRnUnknownMessage m
    ... ... @@ -2701,6 +2704,8 @@ instance Diagnostic TcRnMessage where
    2701 2704 
           -> ErrorWithoutFlag
    2702 2705 
         TcRnUnexpectedTypeSyntaxInTerms{}
    2703 2706 
           -> ErrorWithoutFlag
    2707 
    +    TcRnUnknownPrimCallPackageName {}
    2708 
    +      -> ErrorWithoutFlag
    2704 2709
    2705 2710 
       diagnosticHints = \case
    2706 2711 
         TcRnUnknownMessage m
    ... ... @@ -3427,6 +3432,8 @@ instance Diagnostic TcRnMessage where
    3427 3432 
           -> noHints
    3428 3433 
         TcRnUnexpectedTypeSyntaxInTerms syntax
    3429 3434 
           -> [suggestExtension (typeSyntaxExtension syntax)]
    3435 
    +    TcRnUnknownPrimCallPackageName {}
    3436 
    +      -> noHints
    3430 3437
    3431 3438 
       diagnosticCode = constructorCode @GHC
    3432 3439

  • compiler/GHC/Tc/Errors/Types.hs
    ... ... @@ -212,7 +212,7 @@ import GHC.Types.Var.Set (TyVarSet, VarSet)
    212 212 
     import GHC.Types.DefaultEnv (ClassDefaults)
    213 213
    214 214 
     import GHC.Unit.Types (Module)
    215 
    -import GHC.Unit.State (UnitState)
    215 
    +import GHC.Unit.State (UnitState, PackageName)
    216 216 
     import GHC.Unit.Module.ModIface (ModIface)
    217 217
    218 218 
     import GHC.Utils.Outputable
    ... ... @@ -4436,6 +4436,20 @@ data TcRnMessage where
    4436 4436 
         Test cases: T24159_type_syntax_rn_fail
    4437 4437 
       -}
    4438 4438 
       TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage
    4439 
    +
    4440 
    +  {-| TcRnUnknownPrimCallPackageName is an error that occurs when
    4441 
    +      a 'foreign import prim "pkgname cmmid"' refers to a pkgname
    4442 
    +      that is not a declared dependency (direct or indirect) of the
    4443 
    +      current unit.
    4444 
    +
    4445 
    +      Example:
    4446 
    +       foreign import prim "bad stg_paniczh" panic# :: ...
    4447 
    +
    4448 
    +      Test cases:
    4449 
    +        T27206
    4450 
    +  -}
    4451 
    +  TcRnUnknownPrimCallPackageName :: PackageName -> TcRnMessage
    4452 
    +
    4439 4453 
       deriving Generic
    4440 4454
    4441 4455 
     ----

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -697,6 +697,7 @@ type family GhcDiagnosticCode c = n | n -> c where
    697 697 
       GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms"               = 31244
    698 698 
       GhcDiagnosticCode "TcRnTypeApplicationsDisabled"                  = 23482
    699 699 
       GhcDiagnosticCode "TcRnUnpromotableLit"                           = 51819
    700 
    +  GhcDiagnosticCode "TcRnUnknownPrimCallPackageName"                = 57392
    700 701
    701 702 
       -- TcRnIllegalInvisibleTypePattern
    702 703 
       GhcDiagnosticCode "InvisPatWithoutFlag"                           = 78249

  • compiler/GHC/Types/ForeignCall.hs
    ... ... @@ -33,6 +33,8 @@ module GHC.Types.ForeignCall (
    33 33 
       isSafeForeignCall,
    34 34 
       -- ** CCallSpec
    35 35 
       CCallSpec(..),
    36 
    +  -- ** CLabelSpec
    37 
    +  CLabelSpec(..),
    36 38
    37 39 
       -- * Foreign export types
    38 40 
       -- ** Data-type
    ... ... @@ -203,6 +205,7 @@ instance Outputable CCallSpec where
    203 205 
                     ForeignValue    -> text "__ffi_static_ccall_value"
    204 206 
                     ForeignFunction -> text "__ffi_static_ccall"
    205 207 
                   pprUnit ext = case staticTargetUnit ext of
    208 
    +                CLabelTargetUnknown     -> empty
    206 209 
                     CLabelTargetInUnit unit -> ppr unit
    207 210 
                   (srcTxt, pPkgId) = (staticTargetLabel ext, pprUnit ext)
    208 211 
               in pCallType
    ... ... @@ -229,6 +232,58 @@ typeCheckHeader (Header a b) = Header a b
    229 232 
     renameHeader :: Header GhcPs -> Header GhcRn
    230 233 
     renameHeader (Header a b) = Header a b
    231 234
    235 
    +{-
    236 
    +************************************************************************
    237 
    +*                                                                      *
    238 
    +\subsubsection{C labels}
    239 
    +*                                                                      *
    240 
    +************************************************************************
    241 
    +-}
    242 
    +
    243 
    +-- | A C name (closely related to an assembler label or linker symbol), along
    244 
    +-- with /what/ kind of entity the name refers to and /where/ the the entity
    245 
    +-- lives.
    246 
    +--
    247 
    +-- The \"what\" is whether it refers to a C function or C data (e.g. a C global
    248 
    +-- variable or constant). We track this because we need to know in the backends
    249 
    +-- how to use the name.
    250 
    +--
    251 
    +-- The \"where\" is where the entity that the name refers to lives.
    252 
    +-- Specifically, what shared library it lives in. We track this because on some
    253 
    +-- platforms (especially Windows) the the backend has to generate different
    254 
    +-- code to access symbols depending on whether they are in the current shared
    255 
    +-- library or a different one.
    256 
    +--
    257 
    +-- This is used in Core's representation of 'Literal's, in the 'LitLabel'
    258 
    +-- case, to represent the address of a C entity (function or data) by its name
    259 
    +-- (also called a label or symbol). It gets used in the representation of FFI
    260 
    +-- imports of the address of C names, like:
    261 
    +--
    262 
    +-- > foreign import ccall "foo.h &foo" foo :: Ptr CInt
    263 
    +--
    264 
    +data CLabelSpec
    265 
    +   = CLabelSpec
    266 
    +       !CLabelString            -- name
    267 
    +       !CLabelIsFunctionOrData  -- what
    268 
    +       !CLabelTargetLibrary     -- where
    269 
    +  deriving (Eq, Data)
    270 
    +
    271 
    +type CLabelIsFunctionOrData = ForeignLabelIsFunctionOrData
    272 
    +
    273 
    +instance Binary CLabelSpec where
    274 
    +    put_ bh (CLabelSpec lbl fod tgt) = do
    275 
    +        put_ bh lbl
    276 
    +        put_ bh fod
    277 
    +        put_ bh tgt
    278 
    +    get bh = do
    279 
    +        lbl <- get bh
    280 
    +        fod <- get bh
    281 
    +        tgt <- get bh
    282 
    +        return (CLabelSpec lbl fod tgt)
    283 
    +
    284 
    +instance NFData CLabelSpec where
    285 
    +    rnf (CLabelSpec lbl fod tgt) = rnf lbl `seq` rnf fod `seq` rnf tgt
    286 
    +
    232 287 
     {-
    233 288 
     ************************************************************************
    234 289 
     *                                                                      *
    ... ... @@ -315,13 +370,26 @@ instance Binary CCallConv where
    315 370 
     -- as the target, or if the target is in a different library.
    316 371 
     --
    317 372 
     data CLabelTargetLibrary
    373 
    +
    374 
    +    -- | The entity (that the name\/label points to) is in an unknown shared
    375 
    +    -- library. In particular it could either be in the current library (where
    376 
    +    -- the label is used) or an external one. This case is used for all
    377 
    +    -- user-written Haskell FFI ccall\/capi imports, because in this case we do
    378 
    +    -- not know where the entity the name refers to lives.
    379 
    +  = CLabelTargetUnknown
    380 
    +
    318 381 
         -- | The entity is /known/ to live in a specific Haskell unit (package),
    319 382 
         -- and thus the shared library corresponding to the unit. Uses of this
    320 383 
         -- label within the same unit will be intra-library, and inter-library
    321 384 
         -- otherwise.
    322 
    -  = CLabelTargetInUnit !Unit
    385 
    +  | CLabelTargetInUnit !UnitId
    323 386 
       deriving (Data, Eq)
    324 387
    388 
    +instance Outputable CLabelTargetLibrary where
    389 
    +   ppr CLabelTargetUnknown       = parens (text "unknown library")
    390 
    +   ppr (CLabelTargetInUnit unit) = parens (text "in unit " <> ppr unit)
    391 
    +
    392 
    +
    325 393 
     data StaticTargetGhc = StaticTargetGhc
    326 394 
       { staticTargetLabel :: SourceText
    327 395 
       , staticTargetUnit  :: CLabelTargetLibrary
    ... ... @@ -358,13 +426,16 @@ instance NFData (Header (GhcPass p)) where
    358 426
    359 427 
     instance NFData CLabelTargetLibrary where
    360 428 
         rnf = \case
    429 
    +      CLabelTargetUnknown     -> ()
    361 430 
           CLabelTargetInUnit unit -> rnf unit
    362 431
    363 432 
     instance Binary CLabelTargetLibrary where
    364 433 
         put_ bh = \case
    434 
    +      CLabelTargetUnknown     -> putByte bh 0
    365 435 
           CLabelTargetInUnit unit -> putByte bh 1 *> put_ bh unit
    366 436
    367 437 
         get bh = getByte bh >>= \case
    438 
    +      0 -> pure CLabelTargetUnknown
    368 439 
           _ -> CLabelTargetInUnit <$> get bh
    369 440
    370 441 
     instance NFData CTypeGhc where

  • compiler/GHC/Types/Literal.hs
    ... ... @@ -15,6 +15,7 @@ module GHC.Types.Literal
    15 15 
             , LitNumType(..)
    16 16 
             , LitFloating
    17 17 
             , LitFloatingType(..)
    18 
    +        , CLabelSpec(..)
    18 19
    19 20 
             -- ** Creating Literals
    20 21 
             , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked
    ... ... @@ -144,14 +145,15 @@ data Literal
    144 145 
                                     -- ^ @Float#@ or @Double#@.
    145 146 
                                     -- Create with 'mkLitFloat' or 'mkLitDouble'.
    146 147
    147 
    -  | LitLabel FastString ForeignLabelIsFunctionOrData
    148 
    -                                -- ^ A label literal. Parameters:
    148 
    +  | LitLabel !CLabelSpec        -- ^ A label literal. Parameters:
    149 149 
                                     --
    150 150 
                                     -- 1) The name of the symbol mentioned in the
    151 151 
                                     --    declaration
    152 152 
                                     --
    153 153 
                                     -- 2) Flag indicating whether the symbol
    154 154 
                                     --    references a function or a data
    155 
    +                                --
    156 
    +                                -- 3) Where the thing lives: which shared lib.
    155 157 
       deriving Data
    156 158
    157 159 
     -- | Numeric literal type
    ... ... @@ -265,10 +267,9 @@ instance Binary Literal where
    265 267 
         put_ bh (LitNullAddr)    = putByte bh 2
    266 268 
         put_ bh (LitFloating LitFloat ah)  = do putByte bh 3; put_ bh ah
    267 269 
         put_ bh (LitFloating LitDouble ai) = do putByte bh 4; put_ bh ai
    268 
    -    put_ bh (LitLabel aj fod)
    270 
    +    put_ bh (LitLabel lsp)
    269 271 
             = do putByte bh 5
    270 
    -             put_ bh aj
    271 
    -             put_ bh fod
    272 
    +             put_ bh lsp
    272 273 
         put_ bh (LitNumber nt i)
    273 274 
             = do putByte bh 6
    274 275 
                  put_ bh nt
    ... ... @@ -293,9 +294,8 @@ instance Binary Literal where
    293 294 
                         ai <- get bh
    294 295 
                         return (LitFloating LitDouble ai)
    295 296 
                   5 -> do
    296 
    -                    aj <- get bh
    297 
    -                    fod <- get bh
    298 
    -                    return (LitLabel aj fod)
    297 
    +                    lsp <- get bh
    298 
    +                    return (LitLabel lsp)
    299 299 
                   6 -> do
    300 300 
                         nt <- get bh
    301 301 
                         i  <- get bh
    ... ... @@ -308,7 +308,7 @@ instance NFData Literal where
    308 308 
         rnf (LitString s) = rnf s
    309 309 
         rnf LitNullAddr = ()
    310 310 
         rnf (LitFloating ty f) = rnf ty `seq` rnf f
    311 
    -    rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2
    311 
    +    rnf (LitLabel l) = rnf l
    312 312 
         rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files.
    313 313 
                                  -- See Note [Rubbish literals].
    314 314
    ... ... @@ -844,7 +844,7 @@ literalType (LitChar _) = charPrimTy
    844 844 
     literalType (LitString  _)    = addrPrimTy
    845 845 
     literalType (LitFloating LitFloat  _) = floatPrimTy
    846 846 
     literalType (LitFloating LitDouble _) = doublePrimTy
    847 
    -literalType (LitLabel _ _)    = addrPrimTy
    847 
    +literalType (LitLabel _)      = addrPrimTy
    848 848 
     literalType (LitNumber lt _)  = case lt of
    849 849 
        LitNumBigNat  -> byteArrayPrimTy
    850 850 
        LitNumInt     -> intPrimTy
    ... ... @@ -875,7 +875,8 @@ cmpLit (LitString a) (LitString b) = a `compare` b
    875 875 
     cmpLit (LitNullAddr)        (LitNullAddr)         = EQ
    876 876 
     cmpLit (LitFloating lft1 a) (LitFloating lft2 b)
    877 877 
       = (lft1 `compare` lft2) `mappend` (a `compare` b)
    878 
    -cmpLit (LitLabel     a _) (LitLabel      b _    ) = a `lexicalCompareFS` b
    878 
    +cmpLit (LitLabel (CLabelSpec a _ _))
    879 
    +       (LitLabel (CLabelSpec b _ _))              = a `lexicalCompareFS` b
    879 880 
     cmpLit (LitNumber nt1 a)    (LitNumber nt2  b)
    880 881 
       = (nt1 `compare` nt2) `mappend` (a `compare` b)
    881 882 
     cmpLit (LitRubbish tc1 b1)  (LitRubbish tc2 b2)  = (tc1 `compare` tc2) `mappend`
    ... ... @@ -915,8 +916,8 @@ pprLiteral _ (LitNumber nt i)
    915 916 
            LitNumWord16  -> pprPrimWord16 i
    916 917 
            LitNumWord32  -> pprPrimWord32 i
    917 918 
            LitNumWord64  -> pprPrimWord64 i
    918 
    -pprLiteral add_par (LitLabel l fod) =
    919 
    -    add_par (text "__label" <+> pprHsString l <+> ppr fod)
    919 
    +pprLiteral add_par (LitLabel (CLabelSpec l fod tgt)) =
    920 
    +    add_par (text "__label" <+> pprHsString l <+> ppr fod <+> ppr tgt)
    920 921 
     pprLiteral _       (LitRubbish torc rep)
    921 922 
       = text "RUBBISH" <> pp_tc <> parens (ppr rep)
    922 923 
       where

  • libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
    ... ... @@ -80,7 +80,7 @@ setGlobalAllocationLimitHandler killBehaviour mHandler = do
    80 80 
       setAllocLimitKill shouldKill shouldRunHandler
    81 81
    82 82 
     -- | Retrieves the allocation counter for the another thread.
    83 
    -foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
    83 
    +foreign import prim "rts stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
    84 84 
       :: ThreadId#
    85 85 
       -> State# RealWorld
    86 86 
       -> (# State# RealWorld, Int64# #)

  • libraries/ghc-internal/src/GHC/Internal/Prim/Ext.hs
    ... ... @@ -55,7 +55,7 @@ default () -- Double and Integer aren't available yet
    55 55 
     #if defined(mingw32_HOST_OS)
    56 56
    57 57 
     -- | Asynchronously read bytes from specified file descriptor.
    58 
    -foreign import prim "stg_asyncReadzh" asyncRead#
    58 
    +foreign import prim "rts stg_asyncReadzh" asyncRead#
    59 59 
       :: Int#
    60 60 
       -> Int#
    61 61 
       -> Int#
    ... ... @@ -64,7 +64,7 @@ foreign import prim "stg_asyncReadzh" asyncRead#
    64 64 
       -> (# State# RealWorld, Int#, Int# #)
    65 65
    66 66 
     -- | Asynchronously write bytes from specified file descriptor.
    67 
    -foreign import prim "stg_asyncWritezh" asyncWrite#
    67 
    +foreign import prim "rts stg_asyncWritezh" asyncWrite#
    68 68 
       :: Int#
    69 69 
       -> Int#
    70 70 
       -> Int#
    ... ... @@ -73,7 +73,7 @@ foreign import prim "stg_asyncWritezh" asyncWrite#
    73 73 
       -> (# State# RealWorld, Int#, Int# #)
    74 74
    75 75 
     -- | Asynchronously perform procedure (first arg), passing it 2nd arg.
    76 
    -foreign import prim "stg_asyncDoProczh" asyncDoProc#
    76 
    +foreign import prim "rts stg_asyncDoProczh" asyncDoProc#
    77 77 
       :: Addr#
    78 78 
       -> Addr#
    79 79 
       -> State# RealWorld
    ... ... @@ -86,7 +86,7 @@ foreign import prim "stg_asyncDoProczh" asyncDoProc#
    86 86 
     ------------------------------------------------------------------------
    87 87
    88 88 
     -- | Retrieves the allocation counter for the current thread.
    89 
    -foreign import prim "stg_getThreadAllocationCounterzh" getThreadAllocationCounter#
    89 
    +foreign import prim "rts stg_getThreadAllocationCounterzh" getThreadAllocationCounter#
    90 90 
       :: State# RealWorld
    91 91 
       -> (# State# RealWorld, Int64# #)
    92 92

  • libraries/ghc-internal/src/GHC/Internal/Prim/Panic.hs
    ... ... @@ -72,10 +72,12 @@ absentError to me.
    72 72 
     -- `stg_panic#` never returns but it can't just return `State# RealWorld` so we
    73 73 
     -- indicate that it returns `(# #)` too to make the compiler happy.
    74 74 
     -- See Note [Compiler error functions]
    75 
    -foreign import prim "stg_paniczh" panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #)
    75 
    +foreign import prim "rts stg_paniczh"
    76 
    +  panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #)
    76 77
    77 78 
     -- See Note [Compiler error functions]
    78 
    -foreign import prim "stg_absentErrorzh" stg_absentError# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #)
    79 
    +foreign import prim "rts stg_absentErrorzh"
    80 
    +  stg_absentError# :: Addr# -> State# RealWorld -> (# State# RealWorld, (# #) #)
    79 81
    80 82 
     -- | Display the CString whose address is given as an argument and exit.
    81 83 
     panicError :: Addr# -> a

  • testsuite/tests/rename/should_fail/T27206.hs
    1 
    +{-# LANGUAGE GHCForeignImportPrim #-}
    2 
    +{-# LANGUAGE MagicHash #-}
    3 
    +module T27206 where
    4 
    +
    5 
    +import GHC.Exts
    6 
    +
    7 
    +-- Expect ok for known package rts and ghc-internal, and local/this
    8 
    +foreign import prim "rts          cmm_good1" cmm_good1 :: Int# -> Int#
    9 
    +foreign import prim "ghc-internal cmm_good2" cmm_good2 :: Int# -> Int#
    10 
    +foreign import prim "             cmm_good3" cmm_good3 :: Int# -> Int#
    11 
    +
    12 
    +-- But expect failure for unknown package pkg_foo
    13 
    +foreign import prim "pkg-foo cmm_bad" cmm_bad :: Int# -> Int#

  • testsuite/tests/rename/should_fail/T27206.stderr
    1 
    +T27206.hs:13:21: error: [GHC-57392]
    2 
    +    Unknown source package ‘pkg-foo’ in foreign import prim.
    3 
    +

  • testsuite/tests/rename/should_fail/all.T
    ... ... @@ -264,3 +264,4 @@ test('T25901_sub_c', [extra_files(['T25901_sub_c_helper.hs'])], multimod_compile
    264 264 
     test('T25901_sub_d', [extra_files(['T25901_sub_d_helper.hs'])], multimod_compile_fail, ['T25901_sub_d', '-v0'])
    265 265 
     test('T25901_sub_w', normal, compile_fail, [''])
    266 266 
     test('T26545', normal, compile_fail, [''])
    267 
    +test('T27206', normal, compile_fail, [''])

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