Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

29 changed files:

Changes:

  • changelog.d/fix-duplicate-pmc-warnings
    1 
    +section: compiler
    2 
    +synopsis: Fix duplicate desugaring warnings emitted by the pattern match checker.
    3 
    +  The pattern match checker now suppresses warnings that are already reported
    4 
    +  by the main desugaring pass.
    5 
    +issues: #25996
    6 
    +mrs: !15859

  • compiler/GHC/ByteCode/InfoTable.hs
    ... ... @@ -21,7 +21,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDat
    21 21 
     import GHC.Core.Multiplicity     ( scaledThing )
    22 22
    23 23 
     import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
    24 
    -import GHC.StgToCmm.Closure ( tagForCon )
    24 
    +import GHC.StgToCmm.Closure ( tagForCon, fromDynTag )
    25 25
    26 26 
     import GHC.Utils.Misc
    27 27 
     import GHC.Utils.Panic
    ... ... @@ -58,7 +58,7 @@ make_constr_itbls profile cons =
    58 58 
               ptrs'
    59 59 
               nptrs_really
    60 60 
               conNo
    61 
    -          (tagForCon platform dcon)
    61 
    +          (fromDynTag (tagForCon platform dcon))
    62 62 
               descr
    63 63 
           )
    64 64 
           where

  • compiler/GHC/Cmm/LayoutStack.hs
    ... ... @@ -927,7 +927,7 @@ areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)
    927 927 
         -- Replace (CmmStackSlot area n) with an offset from Sp
    928 928
    929 929 
     areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)
    930 
    -  = mkIntExpr platform sp_hwm
    930 
    +  = mkIntExpr platform (toTargetInt sp_hwm)
    931 931 
         -- Replace CmmHighStackMark with the number of bytes of stack used,
    932 932 
         -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap
    933 933
    ... ... @@ -1199,7 +1199,7 @@ lowerSafeForeignCall profile block
    1199 1199 
     callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
    1200 1200 
     callSuspendThread platform id intrbl =
    1201 1201 
       CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)
    1202 
    -       [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)]
    1202 
    +       [id] [baseExpr platform, mkIntExpr platform (toTargetInt (fromEnum intrbl))]
    1203 1203
    1204 1204 
     callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
    1205 1205 
     callResumeThread new_base id =

  • compiler/GHC/Cmm/Utils.hs
    ... ... @@ -162,12 +162,16 @@ typeForeignHint = primRepForeignHint . typePrimRepU
    162 162 
     --
    163 163 
     ---------------------------------------------------
    164 164
    165 
    --- XXX: should really be Integer, since Int doesn't necessarily cover
    166 
    --- the full range of target Ints.
    167 
    -mkIntCLit :: Platform -> Int -> CmmLit
    165 
    +-- | Make a word-width 'CmmLit' for a target 'Int' value.
    166 
    +-- Uses 'TargetInt' (= 'Int64') rather than host 'Int' to avoid
    167 
    +-- truncation when cross-compiling from a 32-bit host to a 64-bit target.
    168 
    +-- See Note [TargetInt] in GHC.Platform.
    169 
    +mkIntCLit :: Platform -> TargetInt -> CmmLit
    168 170 
     mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)
    169 171
    170 
    -mkIntExpr :: Platform -> Int -> CmmExpr
    172 
    +-- | Make a word-width 'CmmExpr' for a target 'Int' value.
    173 
    +-- See Note [TargetInt] in GHC.Platform.
    174 
    +mkIntExpr :: Platform -> TargetInt -> CmmExpr
    171 175 
     mkIntExpr platform i = CmmLit $! mkIntCLit platform i
    172 176
    173 177 
     zeroCLit :: Platform -> CmmLit
    ... ... @@ -279,7 +283,7 @@ cmmIndexExpr platform width base idx =
    279 283 
       cmmOffsetExpr platform base byte_off
    280 284 
       where
    281 285 
         idx_w = cmmExprWidth platform idx
    282 
    -    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
    286 
    +    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (toTargetInt (widthInLog width))]
    283 287
    284 288 
     cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
    285 289 
     cmmLoadIndex platform ty expr ix =

  • compiler/GHC/HsToCore/Pmc/Desugar.hs
    ... ... @@ -375,16 +375,18 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case
    375 375
    376 376 
     desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
    377 377 
     -- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
    378 
    -desugarPatBind loc var pat =
    378 
    +-- See Note [Suppress warnings in PMC desugaring]
    379 
    +desugarPatBind loc var pat = discardWarningsDs $
    379 380 
       PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat
    380 381
    381 382 
     desugarEmptyCase :: Id -> DsM PmEmptyCase
    382 383 
     desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
    383 384
    384 385 
     -- | Desugar the non-empty 'Match'es of a 'MatchGroup'.
    386 
    +-- See Note [Suppress warnings in PMC desugaring]
    385 387 
     desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
    386 388 
                    -> DsM (PmMatchGroup Pre)
    387 
    -desugarMatches vars matches =
    389 
    +desugarMatches vars matches = discardWarningsDs $
    388 390 
       PmMatchGroup <$> traverse (desugarMatch vars) matches
    389 391
    390 392 
     -- Desugar a single match
    ... ... @@ -398,8 +400,9 @@ desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) =
    398 400 
       -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
    399 401 
       return PmMatch { pm_pats = pats', pm_grhss = grhss' }
    400 402
    403 
    +-- See Note [Suppress warnings in PMC desugaring]
    401 404 
     desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
    402 
    -desugarGRHSs match_loc pp_pats grhss = do
    405 
    +desugarGRHSs match_loc pp_pats grhss = discardWarningsDs $ do
    403 406 
       lcls <- desugarLocalBinds (grhssLocalBinds grhss)
    404 407 
       grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss)
    405 408 
       return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' }
    ... ... @@ -593,6 +596,17 @@ The place to store the 'PmLet' guards for @where@ clauses (which are per
    593 596 
     'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of
    594 597 
     @x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.
    595 598
    599 
    +Note [Suppress warnings in PMC desugaring]
    600 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    601 
    +This module uses 'dsLExpr', 'dsExpr', and 'dsSyntaxExpr' to desugar
    602 
    +expressions into Core for pattern match checking. The main desugaring
    603 
    +pass in GHC.HsToCore processes these same expressions too, so without
    604 
    +suppression any warnings would be emitted twice (#25996).
    605 
    +
    606 
    +To avoid this, the exported functions ('desugarPatBind', 'desugarMatches',
    607 
    +'desugarGRHSs') are wrapped in 'discardWarningsDs', covering all internal
    608 
    +desugarer calls without having to wrap each one individually.
    609 
    +
    596 610 
     Note [Desugaring -XStrict matches in Pmc]
    597 611 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    598 612 
     Consider (#21761)

  • compiler/GHC/Platform.hs
    ... ... @@ -44,6 +44,9 @@ module GHC.Platform
    44 44 
        , platformHsSOName
    45 45 
        , platformSOExt
    46 46 
        , genericPlatform
    47 
    +   -- * Target integer type
    48 
    +   , TargetInt
    49 
    +   , toTargetInt
    47 50 
        )
    48 51 
     where
    49 52
    ... ... @@ -61,6 +64,25 @@ import Data.Int
    61 64 
     import System.FilePath
    62 65 
     import System.Directory
    63 66
    67 
    +-- Note [TargetInt]
    68 
    +-- ~~~~~~~~~~~~~~~~
    69 
    +-- GHC uses 'TargetInt' to represent a value of type 'Int' on the target
    70 
    +-- machine. This is distinct from the host's 'Int' type: when cross-compiling
    71 
    +-- from a 32-bit host to a 64-bit target, the host 'Int' is 32 bits but the
    72 
    +-- target's 'Int' type is 64 bits. Using host 'Int' to store target 'Int'
    73 
    +-- values would cause silent truncation in that scenario.
    74 
    +--
    75 
    +-- We use 'Int64' because it covers the full range of any supported target
    76 
    +-- (32-bit or 64-bit), while still being a fixed-size type that participates in
    77 
    +-- correct signed arithmetic (e.g. bitwise complement, see 'cmmPointerMask').
    78 
    +type TargetInt = Int64
    79 
    +
    80 
    +-- | Convert a host-side 'Int' value to a 'TargetInt'.
    81 
    +-- Use this when converting host-computed counts or offsets into target-sized
    82 
    +-- integers, e.g. when passing to 'mkIntExpr' or 'mkIntCLit'.
    83 
    +toTargetInt :: Int -> TargetInt
    84 
    +toTargetInt = fromIntegral
    85 
    +
    64 86 
     -- | Platform description
    65 87 
     --
    66 88 
     -- This is used to describe platforms so that we can generate code for them.

  • compiler/GHC/Platform/Tag.hs
    ... ... @@ -6,14 +6,24 @@ module GHC.Platform.Tag
    6 6 
       , tAG_MASK
    7 7 
       , mAX_PTR_TAG
    8 8 
       , isSmallFamily
    9 
    +  , toDynTag
    10 
    +  , fromDynTag
    9 11 
       ) where
    10 12
    11 13 
     import GHC.Prelude
    12 14
    13 15 
     import GHC.Platform
    16 
    +import GHC.Utils.Panic.Plain (assert)
    14 17
    15 
    --- | The tag on a pointer (from the dynamic-tagging paper)
    16 
    -type DynTag = Int
    18 
    +import Data.Word (Word8)
    19 
    +
    20 
    +-- | The tag on a pointer (from the dynamic-tagging paper).
    21 
    +-- Wraps a 'Word8' because pointer tags are non-negative and bounded by the
    22 
    +-- number of tag bits on the platform (2 or 3 bits in practice), so values
    23 
    +-- never exceed 7.  Use 'toDynTag' to construct, 'fromDynTag' to extract.
    24 
    +-- See Note [Data constructor dynamic tags].
    25 
    +newtype DynTag = DynTag Word8
    26 
    +  deriving (Eq, Ord, Show)
    17 27
    18 28 
     {- Note [Data constructor dynamic tags]
    19 29 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -35,13 +45,37 @@ The interpreter also needs to be updated if we change the
    35 45 
     tagging strategy; see tagConstr in rts/Interpreter.c.
    36 46 
     -}
    37 47
    38 
    --- | Tag bits mask / maximum pointer tag value, derived from the
    39 
    --- number of tag bits on the platform.
    40 
    -tAG_MASK, mAX_PTR_TAG :: Platform -> Int
    48 
    +-- | Word-sized bitmask of the tag bits (all tag bits set to 1).
    49 
    +-- Used in bitwise operations such as 'cmmTagMask' and 'cmmPointerMask'.
    50 
    +-- This is a 'TargetInt' because it participates in word-width arithmetic
    51 
    +-- on the target (see Note [TargetInt] in GHC.Platform).
    52 
    +tAG_MASK :: Platform -> TargetInt
    41 53 
     tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
    42 
    -mAX_PTR_TAG = tAG_MASK
    54 
    +
    55 
    +-- | Maximum pointer tag value; equivalently the number of tag bits set.
    56 
    +-- This is the 'DynTag' companion to 'tAG_MASK': small enough to fit in
    57 
    +-- 'Word8' since it equals tAG_MASK but is used as a tag number, not a mask.
    58 
    +mAX_PTR_TAG :: Platform -> DynTag
    59 
    +mAX_PTR_TAG platform = DynTag (fromIntegral (tAG_MASK platform))
    60 
    +
    61 
    +-- | Narrow a host-side 'Int' to a 'DynTag', asserting that the value is
    62 
    +-- non-negative and does not exceed 'mAX_PTR_TAG' for the given platform.
    63 
    +toDynTag :: Platform -> Int -> DynTag
    64 
    +toDynTag platform n =
    65 
    +  assert (n >= 0 && n <= fromDynTag (mAX_PTR_TAG platform)) $
    66 
    +  DynTag (fromIntegral n)
    67 
    +
    68 
    +-- | Unwrap a 'DynTag' to a host-side 'Int'.
    69 
    +-- Safe because 'DynTag' values are always small: at most 'mAX_PTR_TAG',
    70 
    +-- bounded by the number of tag bits on the platform (typically 2 or 3 bits,
    71 
    +-- so at most 7).
    72 
    +fromDynTag :: DynTag -> Int
    73 
    +fromDynTag (DynTag w) = fromIntegral w
    43 74
    44 75 
     -- | Is a data type family small enough that each constructor can get
    45 76 
     -- its own pointer tag?
    77 
    +--
    78 
    +-- 'fam_size' is a host-side constructor count; compare against
    79 
    +-- 'mAX_PTR_TAG' via 'fromDynTag' to stay in 'Int' arithmetic.
    46 80 
     isSmallFamily :: Platform -> Int -> Bool
    47 
    -isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
    81 
    +isSmallFamily platform fam_size = fam_size <= fromDynTag (mAX_PTR_TAG platform)

  • compiler/GHC/StgToCmm.hs
    ... ... @@ -303,7 +303,7 @@ cgEnumerationTyCon tycon
    303 303 
       = do platform <- getPlatform
    304 304 
            emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)
    305 305 
                  [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)
    306 
    -                           (tagForCon platform con)
    306 
    +                           (fromDynTag (tagForCon platform con))
    307 307 
                  | con <- tyConDataCons tycon]
    308 308
    309 309 
     cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
    ... ... @@ -342,7 +342,7 @@ cgDataCon mn data_con
    342 342 
                    ; let node = CmmReg $ nodeReg platform
    343 343 
                    ; ldvEnter node
    344 344 
                    ; tickyReturnOldCon (length arg_reps)
    345 
    -               ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)]
    345 
    +               ; void $ emitReturn [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))]
    346 346 
                    }
    347 347 
                         -- The case continuation code expects a tagged pointer
    348 348 
             }

  • compiler/GHC/StgToCmm/Bind.hs
    ... ... @@ -589,7 +589,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
    589 589 
                     ; enterCostCentreFun cc
    590 590 
                         (CmmMachOp (mo_wordSub platform)
    591 591 
                              [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
    592 
    -                         , mkIntExpr platform (funTag platform cl_info) ])
    592 
    +                         , mkIntExpr platform (toTargetInt (fromDynTag (funTag platform cl_info))) ])
    593 593 
                     ; fv_bindings <- mapM bind_fv fv_details
    594 594 
                     -- Load free vars out of closure *after*
    595 595 
                     -- heap check, to reduce live vars over check

  • compiler/GHC/StgToCmm/Closure.hs
    ... ... @@ -12,7 +12,7 @@
    12 12 
     -----------------------------------------------------------------------------
    13 13
    14 14 
     module GHC.StgToCmm.Closure (
    15 
    -        DynTag,  tagForCon, isSmallFamily,
    15 
    +        DynTag, tagForCon, isSmallFamily, toDynTag, fromDynTag,
    16 16
    17 17 
             idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps,
    18 18
    ... ... @@ -65,7 +65,7 @@ module GHC.StgToCmm.Closure (
    65 65
    66 66 
     import GHC.Prelude
    67 67 
     import GHC.Platform
    68 
    -import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily)
    68 
    +import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily, toDynTag, fromDynTag)
    69 69 
     import GHC.Platform.Profile
    70 70
    71 71 
     import GHC.Stg.Syntax
    ... ... @@ -320,13 +320,13 @@ mkLFStringLit = LFUnlifted
    320 320 
     -----------------------------------------------------
    321 321
    322 322 
     tagForCon :: Platform -> DataCon -> DynTag
    323 
    -tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform)
    324 
    --- NB: 1-indexed
    323 
    +-- NB: 1-indexed; result is clamped to mAX_PTR_TAG.
    324 
    +tagForCon platform con = toDynTag platform (min (dataConTag con) (fromDynTag (mAX_PTR_TAG platform)))
    325 325
    326 326 
     tagForArity :: Platform -> RepArity -> DynTag
    327 327 
     tagForArity platform arity
    328 
    - | isSmallFamily platform arity = arity
    329 
    - | otherwise                    = 0
    328 
    + | isSmallFamily platform arity = toDynTag platform arity
    329 
    + | otherwise                    = toDynTag platform 0
    330 330
    331 331 
     -- | Return the tag in the low order bits of a variable bound
    332 332 
     -- to this LambdaForm
    ... ... @@ -334,7 +334,7 @@ lfDynTag :: Platform -> LambdaFormInfo -> DynTag
    334 334 
     lfDynTag platform lf = case lf of
    335 335 
        LFCon con               -> tagForCon   platform con
    336 336 
        LFReEntrant _ arity _ _ -> tagForArity platform arity
    337 
    -   _other                  -> 0
    337 
    +   _other                  -> toDynTag platform 0
    338 338
    339 339
    340 340 
     -----------------------------------------------------------------------------

  • compiler/GHC/StgToCmm/Env.hs
    ... ... @@ -90,7 +90,7 @@ idInfoToAmode cg_info
    90 90
    91 91 
     -- | A tag adds a byte offset to the pointer
    92 92 
     addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
    93 
    -addDynTag = cmmOffsetB
    93 
    +addDynTag platform e tag = cmmOffsetB platform e (fromDynTag tag)
    94 94
    95 95 
     maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
    96 96 
     maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args)

  • compiler/GHC/StgToCmm/Expr.hs
    ... ... @@ -748,7 +748,10 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
    748 748 
                   !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg)
    749 749 
                   !branches' = first succ <$> branches
    750 750 
                   !maxpt = mAX_PTR_TAG platform
    751 
    -              (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'
    751 
    +              -- 'maxpt' is a 'DynTag'; branch tables use host-side 'ConTagZ'
    752 
    +              -- (= 'Int'), so convert via 'fromDynTag'.
    753 
    +              !maxpt_i = fromDynTag maxpt :: ConTagZ
    754 
    +              (!via_ptr, !via_info) = partition ((< maxpt_i) . fst) branches'
    752 755 
                   !small = isSmallFamily platform fam_sz
    753 756
    754 757 
                     -- Is the constructor tag in the node reg?
    ... ... @@ -756,7 +759,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
    756 759 
             ; if small || null via_info
    757 760 
                then -- Yes, bndr_reg has constructor tag in ls bits
    758 761 
                    emitSwitch ptag_expr branches' mb_deflt 1
    759 
    -                 (if small then fam_sz else maxpt)
    762 
    +                 (if small then fam_sz else maxpt_i)
    760 763
    761 764 
                else -- No, the get exact tag from info table when mAX_PTR_TAG
    762 765 
                     -- See Note [Double switching for big families]
    ... ... @@ -772,7 +775,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
    772 775 
                       infos_lbl <- newBlockId
    773 776 
                       infos_scp <- getTickScope
    774 777
    775 
    -                  let spillover = (maxpt, (mkBranch infos_lbl, infos_scp))
    778 
    +                  let spillover = (maxpt_i, (mkBranch infos_lbl, infos_scp))
    776 779
    777 780 
                       (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of
    778 781 
                           (Just (stmts, scp)) ->
    ... ... @@ -781,13 +784,13 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
    781 784 
                                         , Just (mkBranch lbl, scp))
    782 785 
                           _ -> return (Nothing, Nothing)
    783 786 
                       -- Switch on pointer tag
    784 
    -                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt
    787 
    +                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt_i
    785 788 
                       join_lbl <- newBlockId
    786 789 
                       emit (mkBranch join_lbl)
    787 790 
                       -- Switch on info table tag
    788 791 
                       emitLabel infos_lbl
    789 792 
                       emitSwitch itag_expr info0 mb_shared_branch
    790 
    -                    (maxpt - 1) (fam_sz - 1)
    793 
    +                    (maxpt_i - 1) (fam_sz - 1)
    791 794 
                       emitLabel join_lbl
    792 795
    793 796 
             ; return AssignedDirectly }

  • compiler/GHC/StgToCmm/Foreign.hs
    ... ... @@ -621,7 +621,7 @@ openNursery profile tso = do
    621 621 
                    (CmmMachOp (mo_wordMul platform)
    622 622 
                      [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))
    623 623 
                          [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned]
    624 
    -                 , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))
    624 
    +                 , mkIntExpr platform (toTargetInt (pc_BLOCK_SIZE (platformConstants platform)))
    625 625 
                      ])
    626 626 
                    (-1)
    627 627 
                  )

  • compiler/GHC/StgToCmm/Heap.hs
    ... ... @@ -539,7 +539,7 @@ heapCheck checkStack checkYield do_gc code
    539 539 
                          "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
    540 540 
                          "Suggestion: read data from a file instead of having large static data",
    541 541 
                          "structures in code."]
    542 
    -                 | hpHw > 0  = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform)))
    542 
    +                 | hpHw > 0  = Just (mkIntExpr platform (toTargetInt hpHw * toTargetInt (platformWordSizeInBytes platform)))
    543 543 
                      | otherwise = Nothing
    544 544 
                      where
    545 545 
                       constants = platformConstants platform

  • compiler/GHC/StgToCmm/InfoTableProv.hs
    ... ... @@ -117,7 +117,7 @@ emitIpeBufferListNode this_mod ents dus0 = do
    117 117
    118 118 
             ctx      = stgToCmmContext cfg
    119 119 
             platform = stgToCmmPlatform cfg
    120 
    -        int n    = mkIntCLit platform n
    120 
    +        int n    = mkIntCLit platform (toTargetInt n)
    121 121
    122 122 
             ((cg_ipes, unit_id, module_name), strtab) = flip runState emptyStringTable $ do
    123 123 
               unit_id <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleName this_mod)

  • compiler/GHC/StgToCmm/Layout.hs
    ... ... @@ -241,7 +241,7 @@ slowCall fun stg_args
    241 241 
                  end_lbl <- newBlockId
    242 242
    243 243 
                  let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr)
    244 
    -                                                    (mkIntExpr platform n_args)
    244 
    +                                                    (mkIntExpr platform (toTargetInt n_args))
    245 245
    246 246 
                  tscope <- getTickScope
    247 247 
                  emit (mkCbranch (cmmIsTagged platform funv)

  • compiler/GHC/StgToCmm/Prim.hs
    ... ... @@ -172,7 +172,7 @@ emitPrimOp cfg primop =
    172 172 
           -> inlinePrimop $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel
    173 173 
             [ (mkIntExpr platform (fromInteger n),
    174 174 
                fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))
    175 
    -        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),
    175 
    +        , (mkIntExpr platform (toTargetInt (nonHdrSizeW (arrPtrsRep platform (fromInteger n)))),
    176 176 
                fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform))
    177 177 
             ]
    178 178 
             (fromInteger n) init
    ... ... @@ -2240,7 +2240,7 @@ genericWordAddCOp [res_r, res_c] [aa, bb]
    2240 2240 
                     CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]
    2241 2241 
                   ]
    2242 2242 
                 ],
    2243 
    -            mkIntExpr platform (platformWordSizeInBits platform - 1)
    2243 
    +            mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1))
    2244 2244 
               ]
    2245 2245 
             ]
    2246 2246 
     genericWordAddCOp _ _ = panic "genericWordAddCOp"
    ... ... @@ -2273,7 +2273,7 @@ genericWordSubCOp [res_r, res_c] [aa, bb]
    2273 2273 
                     CmmReg (CmmLocal res_r)
    2274 2274 
                   ]
    2275 2275 
                 ],
    2276 
    -            mkIntExpr platform (platformWordSizeInBits platform - 1)
    2276 
    +            mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1))
    2277 2277 
               ]
    2278 2278 
             ]
    2279 2279 
     genericWordSubCOp _ _ = panic "genericWordSubCOp"
    ... ... @@ -2309,7 +2309,7 @@ genericIntAddCOp [res_r, res_c] [aa, bb]
    2309 2309 
                         CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],
    2310 2310 
                         CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
    2311 2311 
                     ],
    2312 
    -                mkIntExpr platform (platformWordSizeInBits platform - 1)
    2312 
    +                mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1))
    2313 2313 
               ]
    2314 2314 
             ]
    2315 2315 
     genericIntAddCOp _ _ = panic "genericIntAddCOp"
    ... ... @@ -2334,7 +2334,7 @@ genericIntSubCOp [res_r, res_c] [aa, bb]
    2334 2334 
                         CmmMachOp (mo_wordXor platform) [aa,bb],
    2335 2335 
                         CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
    2336 2336 
                     ],
    2337 
    -                mkIntExpr platform (platformWordSizeInBits platform - 1)
    2337 
    +                mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1))
    2338 2338 
               ]
    2339 2339 
             ]
    2340 2340 
     genericIntSubCOp _ _ = panic "genericIntSubCOp"
    ... ... @@ -2541,7 +2541,7 @@ doWritePtrArrayOp addr idx val
    2541 2541 
              cmmOffsetExpr platform
    2542 2542 
               (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)
    2543 2543 
                              (ptrArraySize platform profile addr))
    2544 
    -          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])
    2544 
    +          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))])
    2545 2545 
              ) (CmmLit (CmmInt 1 W8))
    2546 2546
    2547 2547 
     mkBasicIndexedRead :: Bool         -- Should this imply an acquire barrier
    ... ... @@ -2922,14 +2922,14 @@ doNewByteArrayOp res_r n = do
    2922 2922 
         let info_ptr = mkLblExpr mkArrWords_infoLabel
    2923 2923 
             rep = arrWordsRep platform n
    2924 2924
    2925 
    -    tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile))
    2926 
    -        (mkIntExpr platform (nonHdrSize platform rep))
    2925 
    +    tickyAllocPrim (mkIntExpr platform (toTargetInt (arrWordsHdrSize profile)))
    2926 
    +        (mkIntExpr platform (toTargetInt (nonHdrSize platform rep)))
    2927 2927 
             (zeroExpr platform)
    2928 2928
    2929 2929 
         let hdr_size = fixedHdrSize profile
    2930 2930
    2931 2931 
         base <- allocHeapClosure rep info_ptr (cccsExpr platform)
    2932 
    -                     [ (mkIntExpr platform n,
    2932 
    +                     [ (mkIntExpr platform (toTargetInt n),
    2933 2933 
                             hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform))
    2934 2934 
                          ]
    2935 2935
    ... ... @@ -3169,8 +3169,8 @@ doNewArrayOp res_r rep info payload n init = do
    3169 3169
    3170 3170 
         let info_ptr = mkLblExpr info
    3171 3171
    3172 
    -    tickyAllocPrim (mkIntExpr platform (hdrSize profile rep))
    3173 
    -        (mkIntExpr platform (nonHdrSize platform rep))
    3172 
    +    tickyAllocPrim (mkIntExpr platform (toTargetInt (hdrSize profile rep)))
    3173 
    +        (mkIntExpr platform (toTargetInt (nonHdrSize platform rep)))
    3174 3174 
             (zeroExpr platform)
    3175 3175
    3176 3176 
         base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload
    ... ... @@ -3214,7 +3214,7 @@ doCopyArrayOp = emitCopyArray copy
    3214 3214 
         -- they're of different types)
    3215 3215 
         copy _src _dst dst_p src_p bytes =
    3216 3216 
             do platform <- getPlatform
    3217 
    -           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)
    3217 
    +           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3218 3218 
                    (wordAlignment platform)
    3219 3219
    3220 3220
    ... ... @@ -3232,9 +3232,9 @@ doCopyMutableArrayOp = emitCopyArray copy
    3232 3232 
         copy src dst dst_p src_p bytes = do
    3233 3233 
             platform <- getPlatform
    3234 3234 
             (moveCall, cpyCall) <- forkAltPair
    3235 
    -            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
    3235 
    +            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3236 3236 
                  (wordAlignment platform))
    3237 
    -            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)
    3237 
    +            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3238 3238 
                  (wordAlignment platform))
    3239 3239 
             emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
    3240 3240
    ... ... @@ -3257,9 +3257,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
    3257 3257 
             dst_off <- assignTempE dst_off0
    3258 3258
    3259 3259 
             whenCheckBounds $ do
    3260 
    -          emitRangeBoundsCheck src_off (mkIntExpr platform n)
    3260 
    +          emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n))
    3261 3261 
                                            (ptrArraySize platform profile src)
    3262 
    -          emitRangeBoundsCheck dst_off (mkIntExpr platform n)
    3262 
    +          emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n))
    3263 3263 
                                            (ptrArraySize platform profile dst)
    3264 3264
    3265 3265 
             -- Nonmoving collector write barrier
    ... ... @@ -3291,7 +3291,7 @@ doCopySmallArrayOp = emitCopySmallArray copy
    3291 3291 
         -- they're of different types)
    3292 3292 
         copy _src _dst dst_p src_p bytes =
    3293 3293 
             do platform <- getPlatform
    3294 
    -           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)
    3294 
    +           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3295 3295 
                    (wordAlignment platform)
    3296 3296
    3297 3297
    ... ... @@ -3305,9 +3305,9 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy
    3305 3305 
         copy src dst dst_p src_p bytes = do
    3306 3306 
             platform <- getPlatform
    3307 3307 
             (moveCall, cpyCall) <- forkAltPair
    3308 
    -            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
    3308 
    +            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3309 3309 
                  (wordAlignment platform))
    3310 
    -            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)
    3310 
    +            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform (toTargetInt bytes))
    3311 3311 
                  (wordAlignment platform))
    3312 3312 
             emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
    3313 3313
    ... ... @@ -3329,9 +3329,9 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n =
    3329 3329 
             dst     <- assignTempE dst0
    3330 3330
    3331 3331 
             whenCheckBounds $ do
    3332 
    -          emitRangeBoundsCheck src_off (mkIntExpr platform n)
    3332 
    +          emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n))
    3333 3333 
                                            (smallPtrArraySize platform profile src)
    3334 
    -          emitRangeBoundsCheck dst_off (mkIntExpr platform n)
    3334 
    +          emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n))
    3335 3335 
                                            (smallPtrArraySize platform profile dst)
    3336 3336
    3337 3337 
             -- Nonmoving collector write barrier
    ... ... @@ -3361,17 +3361,17 @@ emitCloneArray info_p res_r src src_off n = do
    3361 3361 
         let info_ptr = mkLblExpr info_p
    3362 3362 
             rep = arrPtrsRep platform n
    3363 3363
    3364 
    -    tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile))
    3365 
    -        (mkIntExpr platform (nonHdrSize platform rep))
    3364 
    +    tickyAllocPrim (mkIntExpr platform (toTargetInt (arrPtrsHdrSize profile)))
    3365 
    +        (mkIntExpr platform (toTargetInt (nonHdrSize platform rep)))
    3366 3366 
             (zeroExpr platform)
    3367 3367
    3368 3368 
         let hdr_size = fixedHdrSize profile
    3369 3369 
             constants = platformConstants platform
    3370 3370
    3371 3371 
         base <- allocHeapClosure rep info_ptr (cccsExpr platform)
    3372 
    -                     [ (mkIntExpr platform n,
    3372 
    +                     [ (mkIntExpr platform (toTargetInt n),
    3373 3373 
                             hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants)
    3374 
    -                     , (mkIntExpr platform (nonHdrSizeW rep),
    3374 
    +                     , (mkIntExpr platform (toTargetInt (nonHdrSizeW rep)),
    3375 3375 
                             hdr_size + pc_OFFSET_StgMutArrPtrs_size constants)
    3376 3376 
                          ]
    3377 3377
    ... ... @@ -3382,9 +3382,9 @@ emitCloneArray info_p res_r src src_off n = do
    3382 3382 
                  (arrPtrsHdrSize profile)
    3383 3383 
         src_p <- assignTempE $ cmmOffsetExprW platform src
    3384 3384 
                  (cmmAddWord platform
    3385 
    -              (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off)
    3385 
    +              (mkIntExpr platform (toTargetInt (arrPtrsHdrSizeW profile))) src_off)
    3386 3386
    3387 
    -    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
    3387 
    +    emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n)))
    3388 3388 
             (wordAlignment platform)
    3389 3389
    3390 3390 
         emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
    ... ... @@ -3402,14 +3402,14 @@ emitCloneSmallArray info_p res_r src src_off n = do
    3402 3402 
         let info_ptr = mkLblExpr info_p
    3403 3403 
             rep = smallArrPtrsRep n
    3404 3404
    3405 
    -    tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile))
    3406 
    -        (mkIntExpr platform (nonHdrSize platform rep))
    3405 
    +    tickyAllocPrim (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSize profile)))
    3406 
    +        (mkIntExpr platform (toTargetInt (nonHdrSize platform rep)))
    3407 3407 
             (zeroExpr platform)
    3408 3408
    3409 3409 
         let hdr_size = fixedHdrSize profile
    3410 3410
    3411 3411 
         base <- allocHeapClosure rep info_ptr (cccsExpr platform)
    3412 
    -                     [ (mkIntExpr platform n,
    3412 
    +                     [ (mkIntExpr platform (toTargetInt n),
    3413 3413 
                             hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))
    3414 3414 
                          ]
    3415 3415
    ... ... @@ -3420,9 +3420,9 @@ emitCloneSmallArray info_p res_r src src_off n = do
    3420 3420 
                  (smallArrPtrsHdrSize profile)
    3421 3421 
         src_p <- assignTempE $ cmmOffsetExprW platform src
    3422 3422 
                  (cmmAddWord platform
    3423 
    -              (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off)
    3423 
    +              (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSizeW profile))) src_off)
    3424 3424
    3425 
    -    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
    3425 
    +    emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n)))
    3426 3426 
             (wordAlignment platform)
    3427 3427
    3428 3428 
         emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
    ... ... @@ -3437,7 +3437,7 @@ emitSetCards dst_start dst_cards_start n = do
    3437 3437 
         start_card <- assignTempE $ cardCmm platform dst_start
    3438 3438 
         let end_card = cardCmm platform
    3439 3439 
                        (cmmSubWord platform
    3440 
    -                    (cmmAddWord platform dst_start (mkIntExpr platform n))
    3440 
    +                    (cmmAddWord platform dst_start (mkIntExpr platform (toTargetInt n)))
    3441 3441 
                         (mkIntExpr platform 1))
    3442 3442 
         emitMemsetCall (cmmAddWord platform dst_cards_start start_card)
    3443 3443 
             (mkIntExpr platform 1)
    ... ... @@ -3447,7 +3447,7 @@ emitSetCards dst_start dst_cards_start n = do
    3447 3447 
     -- Convert an element index to a card index
    3448 3448 
     cardCmm :: Platform -> CmmExpr -> CmmExpr
    3449 3449 
     cardCmm platform i =
    3450 
    -    cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))
    3450 
    +    cmmUShrWord platform i (mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))))
    3451 3451
    3452 3452 
     ------------------------------------------------------------------------------
    3453 3453 
     -- SmallArray PrimOp implementations
    ... ... @@ -3794,10 +3794,10 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do
    3794 3794 
         platform <- getPlatform
    3795 3795 
         let elem_w = typeWidth elem_ty
    3796 3796 
             idx_w = typeWidth idx_ty
    3797 
    -        elem_sz = mkIntExpr platform $ widthInBytes elem_w
    3797 
    +        elem_sz = mkIntExpr platform $ toTargetInt (widthInBytes elem_w)
    3798 3798 
             arr_sz = byteArraySize platform profile arr
    3799 3799 
             effective_arr_sz =
    3800 
    -          cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w))
    3800 
    +          cmmUShrWord platform arr_sz (mkIntExpr platform (toTargetInt (widthInLog idx_w)))
    3801 3801 
         if elem_w == idx_w
    3802 3802 
           then emitBoundsCheck idx effective_arr_sz  -- aligned => simpler check
    3803 3803 
           else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz)
    ... ... @@ -3839,8 +3839,8 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n =
    3839 3839 
         lbl = mkLblExpr $ mkPrimCallLabel
    3840 3840 
               $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit
    3841 3841 
         args =
    3842 
    -      [ mkIntExpr platform hdr_size
    3842 
    +      [ mkIntExpr platform (toTargetInt hdr_size)
    3843 3843 
           , dst
    3844 3844 
           , dst_off
    3845 
    -      , mkIntExpr platform n
    3845 
    +      , mkIntExpr platform (toTargetInt n)
    3846 3846 
           ]

  • compiler/GHC/StgToCmm/Prof.hs
    ... ... @@ -166,7 +166,7 @@ profDynAlloc rep ccs
    166 166 
       = ifProfiling $
    167 167 
         do profile <- getProfile
    168 168 
            let platform = profilePlatform profile
    169 
    -       profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs
    169 
    +       profAlloc (mkIntExpr platform (toTargetInt (heapClosureSizeW profile rep))) ccs
    170 170
    171 171 
     -- | Record the allocation of a closure (size is given by a CmmExpr)
    172 172 
     -- The size must be in words, because the allocation counter in a CCS counts
    ... ... @@ -182,7 +182,7 @@ profAlloc words ccs
    182 182 
                            (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep))
    183 183 
                                -- subtract the "profiling overhead", which is the
    184 184 
                                -- profiling header in a closure.
    185 
    -                           [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]
    185 
    +                           [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (toTargetInt (profHdrSize profile))]]
    186 186 
                            )
    187 187
    188 188 
     -- -----------------------------------------------------------------------
    ... ... @@ -224,7 +224,7 @@ emitCostCentreDecl :: CostCentre -> FCode ()
    224 224 
     emitCostCentreDecl cc = do
    225 225 
       { ctx      <- stgToCmmContext <$> getStgToCmmConfig
    226 226 
       ; platform <- getPlatform
    227 
    -  ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF
    227 
    +  ; let is_caf | isCafCC cc = mkIntCLit platform (toTargetInt (ord 'c')) -- 'c' == is a CAF
    228 228 
                    | otherwise  = zero platform
    229 229 
                             -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
    230 230 
       ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
    ... ... @@ -347,7 +347,7 @@ dynLdvInit :: Platform -> CmmExpr
    347 347 
     dynLdvInit platform =
    348 348 
     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
    349 349 
       CmmMachOp (mo_wordOr platform) [
    350 
    -      CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))],
    350 
    +      CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (toTargetInt (pc_LDV_SHIFT (platformConstants platform)))],
    351 351 
           CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform)))
    352 352 
       ]
    353 353
    ... ... @@ -390,7 +390,7 @@ ldvEnterClosure closure_info node_reg = do
    390 390 
         platform <- getPlatform
    391 391 
         let tag = funTag platform closure_info
    392 392 
         -- don't forget to subtract node's tag
    393 
    -    ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))
    393 
    +    ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-(fromDynTag tag)))
    394 394
    395 395 
     ldvEnter :: CmmExpr -> FCode ()
    396 396 
     -- Argument is a closure pointer

  • compiler/GHC/StgToCmm/Ticky.hs
    ... ... @@ -294,7 +294,7 @@ emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =
    294 294 
         -- before, but the code generator wasn't handling that
    295 295 
         -- properly and it led to chaos, panic and disorder.
    296 296 
             [ zeroCLit platform,               -- registered?
    297 
    -          mkIntCLit platform arity,   -- Arity
    297 
    +          mkIntCLit platform (toTargetInt arity),   -- Arity
    298 298 
               zeroCLit platform,               -- Heap allocated for this thing
    299 299 
               fun_desc,
    300 300 
               arg_desc,
    ... ... @@ -848,7 +848,7 @@ bumpHistogram lbl n = do
    848 848 
     emitAddToMem :: CmmExpr -> Int -> FCode ()
    849 849 
     emitAddToMem lhs n = do
    850 850 
       platform <- getPlatform
    851 
    -  emitAddToMemE lhs (mkIntExpr platform n)
    851 
    +  emitAddToMemE lhs (mkIntExpr platform (toTargetInt n))
    852 852
    853 853 
     emitAddToMemE :: CmmExpr -> CmmExpr -> FCode ()
    854 854 
     emitAddToMemE lhs n = do

  • compiler/GHC/StgToCmm/Utils.hs
    ... ... @@ -160,7 +160,7 @@ mkTaggedObjectLoad platform reg base offset tag
    160 160 
       = mkAssign (CmmLocal reg)
    161 161 
                  (CmmLoad (cmmOffsetB platform
    162 162 
                                       (CmmReg (CmmLocal base))
    163 
    -                                  (offset - tag))
    163 
    +                                  (offset - fromDynTag tag))
    164 164 
                           (localRegType reg)
    165 165 
                           NaturallyAligned)
    166 166

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -2367,8 +2367,9 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
    2367 2367 
                             -- The two-step process avoids getting two errors: one from
    2368 2368 
                             -- the expression itself, and one from the 'print it' part
    2369 2369 
                             -- This two-step story is very clunky, alas
    2370 
    -                  , do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
    2370 
    +                  , do { _ <- checkNoErrs (discardWarnings (tcGhciStmts [let_stmt]))
    2371 2371 
                                     --- checkNoErrs defeats the error recovery of let-bindings
    2372 
    +                                --- discardWarnings: warnings come from the second typecheck
    2372 2373 
                            ; tcGhciStmts [let_stmt, print_it] } ]
    2373 2374
    2374 2375 
                   -- Plans where we don't bind "it"

  • docs/users_guide/packages.rst
    ... ... @@ -600,7 +600,7 @@ must be relative to the location of the package environment file.
    600 600 
         :category:
    601 601
    602 602 
         Use the package environment in ⟨file⟩, or in
    603 
    -    ``$XDG_DATA_HOME/ghc/arch-os-version/environments/⟨name⟩``
    603 
    +    ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/⟨name⟩``
    604 604 
         If set to ``-`` no package environment is read.
    605 605
    606 606 
     .. envvar:: GHC_ENVIRONMENT
    ... ... @@ -613,13 +613,13 @@ locations:
    613 613
    614 614 
     -  File ⟨file⟩ if you pass the option :ghc-flag:`-package-env ⟨file⟩|⟨name⟩`.
    615 615
    616 
    --  File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if you pass the
    616 
    +-  File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if you pass the
    617 617 
        option ``-package-env ⟨name⟩``.
    618 618
    619 619 
     -  File ⟨file⟩ if the environment variable :envvar:`GHC_ENVIRONMENT` is set to
    620 620 
        ⟨file⟩.
    621 621
    622 
    --  File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if the
    622 
    +-  File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if the
    623 623 
        environment variable :envvar:`GHC_ENVIRONMENT` is set to ⟨name⟩.
    624 624
    625 625 
     Additionally, unless ``-hide-all-packages`` is specified ``ghc`` will also
    ... ... @@ -628,7 +628,7 @@ look for the package environment in the following locations:
    628 628 
     -  File ``.ghc.environment.arch-os-version`` if it exists in the current
    629 629 
        directory or any parent directory (but not the user's home directory).
    630 630
    631 
    --  File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/default`` if it
    631 
    +-  File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/default`` if it
    632 632 
        exists.
    633 633
    634 634 
     Package environments can be modified by further command line arguments;

  • testsuite/tests/deSugar/should_compile/T25996.hs
    1 
    +{-# OPTIONS_GHC -Wall #-}
    2 
    +{-# OPTIONS_GHC -Wno-unused-local-binds #-}
    3 
    +{-# OPTIONS_GHC -Wno-unused-top-binds #-}
    4 
    +
    5 
    +main :: IO ()
    6 
    +main = do
    7 
    +  pure ()
    8 
    +  where
    9 
    +    biz :: IO ()
    10 
    +    biz = do
    11 
    +      pure (10 :: Integer)
    12 
    +      pure ()
    13 
    +
    14 
    +biz' :: IO ()
    15 
    +biz' = do
    16 
    +  pure (10 :: Integer)
    17 
    +  pure ()

  • testsuite/tests/deSugar/should_compile/T25996.stderr
    1 
    +T25996.hs:11:7: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)]
    2 
    +    A do-notation statement discarded a result of type ‘Integer’
    3 
    +    Suggested fix:
    4 
    +      Suppress this warning by saying ‘_ <- pure (10 :: Integer)’
    5 
    +
    6 
    +T25996.hs:16:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)]
    7 
    +    A do-notation statement discarded a result of type ‘Integer’
    8 
    +    Suggested fix:
    9 
    +      Suppress this warning by saying ‘_ <- pure (10 :: Integer)’
    10 
    +

  • testsuite/tests/deSugar/should_compile/all.T
    ... ... @@ -115,3 +115,4 @@ test('T19883', normal, compile, [''])
    115 115 
     test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
    116 116 
     test('T23550', normal, compile, [''])
    117 117 
     test('T24489', normal, compile, ['-O'])
    118 
    +test('T25996', normal, compile, [''])

  • testsuite/tests/ghci/scripts/T26233.script
    1 
    +:set -Wall
    2 
    +truncate pi

  • testsuite/tests/ghci/scripts/T26233.stderr
    1 
    +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)]
    2 
    +    • Defaulting the type variable ‘a0’ to type ‘Double’ in the following constraints
    3 
    +        (RealFrac a0)
    4 
    +          arising from a use of ‘truncate’ at <interactive>:2:1-8
    5 
    +        (Floating a0) arising from a use of ‘pi’ at <interactive>:2:10-11
    6 
    +    • In the expression: truncate pi
    7 
    +      In an equation for ‘it’: it = truncate pi
    8 
    +
    9 
    +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)]
    10 
    +    • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints
    11 
    +        (Show a0) arising from a use of ‘print’ at <interactive>:2:1-11
    12 
    +        (Integral a0) arising from a use of ‘it’ at <interactive>:2:1-11
    13 
    +    • In a stmt of an interactive GHCi command: print it
    14 
    +

  • testsuite/tests/ghci/scripts/T26233.stdout
    1 
    +3

  • testsuite/tests/ghci/scripts/all.T
    ... ... @@ -391,3 +391,4 @@ test('GhciPackageRename',
    391 391 
          [extra_hc_opts("-hide-all-packages -package 'containers (Data.Map as Prelude)'")],
    392 392 
          ghci_script,
    393 393 
          ['GhciPackageRename.script'])
    394 
    +test('T26233', normal, ghci_script, ['T26233.script'])

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