Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 585d7450 by Luite Stegeman at 2026-04-11T02:17:13-04:00 tc: discard warnings in tcUserStmt Plan C We typecheck let_stmt twice, but we don't want the warnings twice! see #26233 - - - - - 2df604e9 by Sylvain Henry at 2026-04-11T02:19:30-04:00 Introduce TargetInt to represent target's Int (#15973) GHC was using host 'Int' in several places to represent values that live in the target machine's 'Int' type. This is silently wrong when cross-compiling from a 32-bit host to a 64-bit target: the host Int is 32 bits while the target Int is 64 bits. See Note [TargetInt] in GHC.Platform. Also used the opportunity to make DynTag = Word8. Fixes #15973 Co-Authored-By: Claude Sonnet 4.6 - - - - - 15b335ac by Luite Stegeman at 2026-04-13T05:19:21-04:00 Suppress desugaring warnings in the pattern match checker Avoid duplicating warnings from the actual desugaring pass. fixes #25996 - - - - - 8501dce1 by Phil de Joux at 2026-04-13T05:19:31-04:00 Typo ~/ghc/arch-os-version/environments - - - - - 29 changed files: - + changelog.d/fix-duplicate-pmc-warnings - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/LayoutStack.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/Platform.hs - compiler/GHC/Platform/Tag.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/StgToCmm/InfoTableProv.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Prof.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/Tc/Module.hs - docs/users_guide/packages.rst - + testsuite/tests/deSugar/should_compile/T25996.hs - + testsuite/tests/deSugar/should_compile/T25996.stderr - testsuite/tests/deSugar/should_compile/all.T - + testsuite/tests/ghci/scripts/T26233.script - + testsuite/tests/ghci/scripts/T26233.stderr - + testsuite/tests/ghci/scripts/T26233.stdout - testsuite/tests/ghci/scripts/all.T Changes: ===================================== changelog.d/fix-duplicate-pmc-warnings ===================================== @@ -0,0 +1,6 @@ +section: compiler +synopsis: Fix duplicate desugaring warnings emitted by the pattern match checker. + The pattern match checker now suppresses warnings that are already reported + by the main desugaring pass. +issues: #25996 +mrs: !15859 ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDat import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon ) +import GHC.StgToCmm.Closure ( tagForCon, fromDynTag ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -58,7 +58,7 @@ make_constr_itbls profile cons = ptrs' nptrs_really conNo - (tagForCon platform dcon) + (fromDynTag (tagForCon platform dcon)) descr ) where ===================================== compiler/GHC/Cmm/LayoutStack.hs ===================================== @@ -927,7 +927,7 @@ areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) -- Replace (CmmStackSlot area n) with an offset from Sp areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) - = mkIntExpr platform sp_hwm + = mkIntExpr platform (toTargetInt sp_hwm) -- Replace CmmHighStackMark with the number of bytes of stack used, -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap @@ -1199,7 +1199,7 @@ lowerSafeForeignCall profile block callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl = CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) - [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] + [id] [baseExpr platform, mkIntExpr platform (toTargetInt (fromEnum intrbl))] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -162,12 +162,16 @@ typeForeignHint = primRepForeignHint . typePrimRepU -- --------------------------------------------------- --- XXX: should really be Integer, since Int doesn't necessarily cover --- the full range of target Ints. -mkIntCLit :: Platform -> Int -> CmmLit +-- | Make a word-width 'CmmLit' for a target 'Int' value. +-- Uses 'TargetInt' (= 'Int64') rather than host 'Int' to avoid +-- truncation when cross-compiling from a 32-bit host to a 64-bit target. +-- See Note [TargetInt] in GHC.Platform. +mkIntCLit :: Platform -> TargetInt -> CmmLit mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform) -mkIntExpr :: Platform -> Int -> CmmExpr +-- | Make a word-width 'CmmExpr' for a target 'Int' value. +-- See Note [TargetInt] in GHC.Platform. +mkIntExpr :: Platform -> TargetInt -> CmmExpr mkIntExpr platform i = CmmLit $! mkIntCLit platform i zeroCLit :: Platform -> CmmLit @@ -279,7 +283,7 @@ cmmIndexExpr platform width base idx = cmmOffsetExpr platform base byte_off where idx_w = cmmExprWidth platform idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (toTargetInt (widthInLog width))] cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr cmmLoadIndex platform ty expr ix = ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -375,16 +375,18 @@ desugarConPatOut x con univ_tys ex_tvs dicts = \case desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre) -- See 'GrdPatBind' for how this simply repurposes GrdGRHS. -desugarPatBind loc var pat = +-- See Note [Suppress warnings in PMC desugaring] +desugarPatBind loc var pat = discardWarningsDs $ PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) <$> desugarPat var pat desugarEmptyCase :: Id -> DsM PmEmptyCase desugarEmptyCase var = pure PmEmptyCase { pe_var = var } -- | Desugar the non-empty 'Match'es of a 'MatchGroup'. +-- See Note [Suppress warnings in PMC desugaring] desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc)) -> DsM (PmMatchGroup Pre) -desugarMatches vars matches = +desugarMatches vars matches = discardWarningsDs $ PmMatchGroup <$> traverse (desugarMatch vars) matches -- Desugar a single match @@ -398,8 +400,9 @@ desugarMatch vars (L match_loc (Match { m_pats = L _ pats, m_grhss = grhss })) = -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) return PmMatch { pm_pats = pats', pm_grhss = grhss' } +-- See Note [Suppress warnings in PMC desugaring] desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre) -desugarGRHSs match_loc pp_pats grhss = do +desugarGRHSs match_loc pp_pats grhss = discardWarningsDs $ do lcls <- desugarLocalBinds (grhssLocalBinds grhss) grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss) 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 'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of @x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'. +Note [Suppress warnings in PMC desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module uses 'dsLExpr', 'dsExpr', and 'dsSyntaxExpr' to desugar +expressions into Core for pattern match checking. The main desugaring +pass in GHC.HsToCore processes these same expressions too, so without +suppression any warnings would be emitted twice (#25996). + +To avoid this, the exported functions ('desugarPatBind', 'desugarMatches', +'desugarGRHSs') are wrapped in 'discardWarningsDs', covering all internal +desugarer calls without having to wrap each one individually. + Note [Desugaring -XStrict matches in Pmc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#21761) ===================================== compiler/GHC/Platform.hs ===================================== @@ -44,6 +44,9 @@ module GHC.Platform , platformHsSOName , platformSOExt , genericPlatform + -- * Target integer type + , TargetInt + , toTargetInt ) where @@ -61,6 +64,25 @@ import Data.Int import System.FilePath import System.Directory +-- Note [TargetInt] +-- ~~~~~~~~~~~~~~~~ +-- GHC uses 'TargetInt' to represent a value of type 'Int' on the target +-- machine. This is distinct from the host's 'Int' type: when cross-compiling +-- from a 32-bit host to a 64-bit target, the host 'Int' is 32 bits but the +-- target's 'Int' type is 64 bits. Using host 'Int' to store target 'Int' +-- values would cause silent truncation in that scenario. +-- +-- We use 'Int64' because it covers the full range of any supported target +-- (32-bit or 64-bit), while still being a fixed-size type that participates in +-- correct signed arithmetic (e.g. bitwise complement, see 'cmmPointerMask'). +type TargetInt = Int64 + +-- | Convert a host-side 'Int' value to a 'TargetInt'. +-- Use this when converting host-computed counts or offsets into target-sized +-- integers, e.g. when passing to 'mkIntExpr' or 'mkIntCLit'. +toTargetInt :: Int -> TargetInt +toTargetInt = fromIntegral + -- | Platform description -- -- 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 , tAG_MASK , mAX_PTR_TAG , isSmallFamily + , toDynTag + , fromDynTag ) where import GHC.Prelude import GHC.Platform +import GHC.Utils.Panic.Plain (assert) --- | The tag on a pointer (from the dynamic-tagging paper) -type DynTag = Int +import Data.Word (Word8) + +-- | The tag on a pointer (from the dynamic-tagging paper). +-- Wraps a 'Word8' because pointer tags are non-negative and bounded by the +-- number of tag bits on the platform (2 or 3 bits in practice), so values +-- never exceed 7. Use 'toDynTag' to construct, 'fromDynTag' to extract. +-- See Note [Data constructor dynamic tags]. +newtype DynTag = DynTag Word8 + deriving (Eq, Ord, Show) {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -35,13 +45,37 @@ The interpreter also needs to be updated if we change the tagging strategy; see tagConstr in rts/Interpreter.c. -} --- | Tag bits mask / maximum pointer tag value, derived from the --- number of tag bits on the platform. -tAG_MASK, mAX_PTR_TAG :: Platform -> Int +-- | Word-sized bitmask of the tag bits (all tag bits set to 1). +-- Used in bitwise operations such as 'cmmTagMask' and 'cmmPointerMask'. +-- This is a 'TargetInt' because it participates in word-width arithmetic +-- on the target (see Note [TargetInt] in GHC.Platform). +tAG_MASK :: Platform -> TargetInt tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1 -mAX_PTR_TAG = tAG_MASK + +-- | Maximum pointer tag value; equivalently the number of tag bits set. +-- This is the 'DynTag' companion to 'tAG_MASK': small enough to fit in +-- 'Word8' since it equals tAG_MASK but is used as a tag number, not a mask. +mAX_PTR_TAG :: Platform -> DynTag +mAX_PTR_TAG platform = DynTag (fromIntegral (tAG_MASK platform)) + +-- | Narrow a host-side 'Int' to a 'DynTag', asserting that the value is +-- non-negative and does not exceed 'mAX_PTR_TAG' for the given platform. +toDynTag :: Platform -> Int -> DynTag +toDynTag platform n = + assert (n >= 0 && n <= fromDynTag (mAX_PTR_TAG platform)) $ + DynTag (fromIntegral n) + +-- | Unwrap a 'DynTag' to a host-side 'Int'. +-- Safe because 'DynTag' values are always small: at most 'mAX_PTR_TAG', +-- bounded by the number of tag bits on the platform (typically 2 or 3 bits, +-- so at most 7). +fromDynTag :: DynTag -> Int +fromDynTag (DynTag w) = fromIntegral w -- | Is a data type family small enough that each constructor can get -- its own pointer tag? +-- +-- 'fam_size' is a host-side constructor count; compare against +-- 'mAX_PTR_TAG' via 'fromDynTag' to stay in 'Int' arithmetic. isSmallFamily :: Platform -> Int -> Bool -isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform +isSmallFamily platform fam_size = fam_size <= fromDynTag (mAX_PTR_TAG platform) ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -303,7 +303,7 @@ cgEnumerationTyCon tycon = do platform <- getPlatform emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs) - (tagForCon platform con) + (fromDynTag (tagForCon platform con)) | con <- tyConDataCons tycon] cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () @@ -342,7 +342,7 @@ cgDataCon mn data_con ; let node = CmmReg $ nodeReg platform ; ldvEnter node ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)] + ; void $ emitReturn [cmmOffsetB platform node (fromDynTag (tagForCon platform data_con))] } -- The case continuation code expects a tagged pointer } ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -589,7 +589,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details ; enterCostCentreFun cc (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag platform cl_info) ]) + , mkIntExpr platform (toTargetInt (fromDynTag (funTag platform cl_info))) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -12,7 +12,7 @@ ----------------------------------------------------------------------------- module GHC.StgToCmm.Closure ( - DynTag, tagForCon, isSmallFamily, + DynTag, tagForCon, isSmallFamily, toDynTag, fromDynTag, idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, @@ -65,7 +65,7 @@ module GHC.StgToCmm.Closure ( import GHC.Prelude import GHC.Platform -import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily) +import GHC.Platform.Tag (DynTag, mAX_PTR_TAG, isSmallFamily, toDynTag, fromDynTag) import GHC.Platform.Profile import GHC.Stg.Syntax @@ -320,13 +320,13 @@ mkLFStringLit = LFUnlifted ----------------------------------------------------- tagForCon :: Platform -> DataCon -> DynTag -tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) --- NB: 1-indexed +-- NB: 1-indexed; result is clamped to mAX_PTR_TAG. +tagForCon platform con = toDynTag platform (min (dataConTag con) (fromDynTag (mAX_PTR_TAG platform))) tagForArity :: Platform -> RepArity -> DynTag tagForArity platform arity - | isSmallFamily platform arity = arity - | otherwise = 0 + | isSmallFamily platform arity = toDynTag platform arity + | otherwise = toDynTag platform 0 -- | Return the tag in the low order bits of a variable bound -- to this LambdaForm @@ -334,7 +334,7 @@ lfDynTag :: Platform -> LambdaFormInfo -> DynTag lfDynTag platform lf = case lf of LFCon con -> tagForCon platform con LFReEntrant _ arity _ _ -> tagForArity platform arity - _other -> 0 + _other -> toDynTag platform 0 ----------------------------------------------------------------------------- ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -90,7 +90,7 @@ idInfoToAmode cg_info -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr -addDynTag = cmmOffsetB +addDynTag platform e tag = cmmOffsetB platform e (fromDynTag tag) maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) 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 !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) !branches' = first succ <$> branches !maxpt = mAX_PTR_TAG platform - (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches' + -- 'maxpt' is a 'DynTag'; branch tables use host-side 'ConTagZ' + -- (= 'Int'), so convert via 'fromDynTag'. + !maxpt_i = fromDynTag maxpt :: ConTagZ + (!via_ptr, !via_info) = partition ((< maxpt_i) . fst) branches' !small = isSmallFamily platform fam_sz -- Is the constructor tag in the node reg? @@ -756,7 +759,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts ; if small || null via_info then -- Yes, bndr_reg has constructor tag in ls bits emitSwitch ptag_expr branches' mb_deflt 1 - (if small then fam_sz else maxpt) + (if small then fam_sz else maxpt_i) else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] @@ -772,7 +775,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts infos_lbl <- newBlockId infos_scp <- getTickScope - let spillover = (maxpt, (mkBranch infos_lbl, infos_scp)) + let spillover = (maxpt_i, (mkBranch infos_lbl, infos_scp)) (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of (Just (stmts, scp)) -> @@ -781,13 +784,13 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts , Just (mkBranch lbl, scp)) _ -> return (Nothing, Nothing) -- Switch on pointer tag - emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt + emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt_i join_lbl <- newBlockId emit (mkBranch join_lbl) -- Switch on info table tag emitLabel infos_lbl emitSwitch itag_expr info0 mb_shared_branch - (maxpt - 1) (fam_sz - 1) + (maxpt_i - 1) (fam_sz - 1) emitLabel join_lbl ; return AssignedDirectly } ===================================== compiler/GHC/StgToCmm/Foreign.hs ===================================== @@ -621,7 +621,7 @@ openNursery profile tso = do (CmmMachOp (mo_wordMul platform) [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned] - , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) + , mkIntExpr platform (toTargetInt (pc_BLOCK_SIZE (platformConstants platform))) ]) (-1) ) ===================================== compiler/GHC/StgToCmm/Heap.hs ===================================== @@ -539,7 +539,7 @@ heapCheck checkStack checkYield do_gc code "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.", "Suggestion: read data from a file instead of having large static data", "structures in code."] - | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) + | hpHw > 0 = Just (mkIntExpr platform (toTargetInt hpHw * toTargetInt (platformWordSizeInBytes platform))) | otherwise = Nothing where constants = platformConstants platform ===================================== compiler/GHC/StgToCmm/InfoTableProv.hs ===================================== @@ -117,7 +117,7 @@ emitIpeBufferListNode this_mod ents dus0 = do ctx = stgToCmmContext cfg platform = stgToCmmPlatform cfg - int n = mkIntCLit platform n + int n = mkIntCLit platform (toTargetInt n) ((cg_ipes, unit_id, module_name), strtab) = flip runState emptyStringTable $ do unit_id <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleName this_mod) ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -241,7 +241,7 @@ slowCall fun stg_args end_lbl <- newBlockId let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) - (mkIntExpr platform n_args) + (mkIntExpr platform (toTargetInt n_args)) tscope <- getTickScope emit (mkCbranch (cmmIsTagged platform funv) ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -172,7 +172,7 @@ emitPrimOp cfg primop = -> inlinePrimop $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) - , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), + , (mkIntExpr platform (toTargetInt (nonHdrSizeW (arrPtrsRep platform (fromInteger n)))), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init @@ -2240,7 +2240,7 @@ genericWordAddCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)] ] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericWordAddCOp _ _ = panic "genericWordAddCOp" @@ -2273,7 +2273,7 @@ genericWordSubCOp [res_r, res_c] [aa, bb] CmmReg (CmmLocal res_r) ] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericWordSubCOp _ _ = panic "genericWordSubCOp" @@ -2309,7 +2309,7 @@ genericIntAddCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]], CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericIntAddCOp _ _ = panic "genericIntAddCOp" @@ -2334,7 +2334,7 @@ genericIntSubCOp [res_r, res_c] [aa, bb] CmmMachOp (mo_wordXor platform) [aa,bb], CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr platform (platformWordSizeInBits platform - 1) + mkIntExpr platform (toTargetInt (platformWordSizeInBits platform - 1)) ] ] genericIntSubCOp _ _ = panic "genericIntSubCOp" @@ -2541,7 +2541,7 @@ doWritePtrArrayOp addr idx val cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) (ptrArraySize platform profile addr)) - (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) + (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))]) ) (CmmLit (CmmInt 1 W8)) mkBasicIndexedRead :: Bool -- Should this imply an acquire barrier @@ -2922,14 +2922,14 @@ doNewByteArrayOp res_r n = do let info_ptr = mkLblExpr mkArrWords_infoLabel rep = arrWordsRep platform n - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (arrWordsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] @@ -3169,8 +3169,8 @@ doNewArrayOp res_r rep info payload n init = do let info_ptr = mkLblExpr info - tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (hdrSize profile rep))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload @@ -3214,7 +3214,7 @@ doCopyArrayOp = emitCopyArray copy -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform) @@ -3232,9 +3232,9 @@ doCopyMutableArrayOp = emitCopyArray copy copy src dst dst_p src_p bytes = do platform <- getPlatform (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall @@ -3257,9 +3257,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n = dst_off <- assignTempE dst_off0 whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) + emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n)) (ptrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) + emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n)) (ptrArraySize platform profile dst) -- Nonmoving collector write barrier @@ -3291,7 +3291,7 @@ doCopySmallArrayOp = emitCopySmallArray copy -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform) @@ -3305,9 +3305,9 @@ doCopySmallMutableArrayOp = emitCopySmallArray copy copy src dst dst_p src_p bytes = do platform <- getPlatform (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt bytes)) (wordAlignment platform)) emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall @@ -3329,9 +3329,9 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = dst <- assignTempE dst0 whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) + emitRangeBoundsCheck src_off (mkIntExpr platform (toTargetInt n)) (smallPtrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) + emitRangeBoundsCheck dst_off (mkIntExpr platform (toTargetInt n)) (smallPtrArraySize platform profile dst) -- Nonmoving collector write barrier @@ -3361,17 +3361,17 @@ emitCloneArray info_p res_r src src_off n = do let info_ptr = mkLblExpr info_p rep = arrPtrsRep platform n - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (arrPtrsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile constants = platformConstants platform base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) - , (mkIntExpr platform (nonHdrSizeW rep), + , (mkIntExpr platform (toTargetInt (nonHdrSizeW rep)), hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) ] @@ -3382,9 +3382,9 @@ emitCloneArray info_p res_r src src_off n = do (arrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) + (mkIntExpr platform (toTargetInt (arrPtrsHdrSizeW profile))) src_off) - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n))) (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -3402,14 +3402,14 @@ emitCloneSmallArray info_p res_r src src_off n = do let info_ptr = mkLblExpr info_p rep = smallArrPtrsRep n - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) + tickyAllocPrim (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSize profile))) + (mkIntExpr platform (toTargetInt (nonHdrSize platform rep))) (zeroExpr platform) let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, + [ (mkIntExpr platform (toTargetInt n), hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] @@ -3420,9 +3420,9 @@ emitCloneSmallArray info_p res_r src src_off n = do (smallArrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) + (mkIntExpr platform (toTargetInt (smallArrPtrsHdrSizeW profile))) src_off) - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + emitMemcpyCall dst_p src_p (mkIntExpr platform (toTargetInt (wordsToBytes platform n))) (wordAlignment platform) emit $ mkAssign (CmmLocal res_r) (CmmReg arr) @@ -3437,7 +3437,7 @@ emitSetCards dst_start dst_cards_start n = do start_card <- assignTempE $ cardCmm platform dst_start let end_card = cardCmm platform (cmmSubWord platform - (cmmAddWord platform dst_start (mkIntExpr platform n)) + (cmmAddWord platform dst_start (mkIntExpr platform (toTargetInt n))) (mkIntExpr platform 1)) emitMemsetCall (cmmAddWord platform dst_cards_start start_card) (mkIntExpr platform 1) @@ -3447,7 +3447,7 @@ emitSetCards dst_start dst_cards_start n = do -- Convert an element index to a card index cardCmm :: Platform -> CmmExpr -> CmmExpr cardCmm platform i = - cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) + cmmUShrWord platform i (mkIntExpr platform (toTargetInt (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))) ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations @@ -3794,10 +3794,10 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do platform <- getPlatform let elem_w = typeWidth elem_ty idx_w = typeWidth idx_ty - elem_sz = mkIntExpr platform $ widthInBytes elem_w + elem_sz = mkIntExpr platform $ toTargetInt (widthInBytes elem_w) arr_sz = byteArraySize platform profile arr effective_arr_sz = - cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) + cmmUShrWord platform arr_sz (mkIntExpr platform (toTargetInt (widthInLog idx_w))) if elem_w == idx_w then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) @@ -3839,8 +3839,8 @@ emitCopyUpdRemSetPush platform hdr_size dst dst_off n = lbl = mkLblExpr $ mkPrimCallLabel $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit args = - [ mkIntExpr platform hdr_size + [ mkIntExpr platform (toTargetInt hdr_size) , dst , dst_off - , mkIntExpr platform n + , mkIntExpr platform (toTargetInt n) ] ===================================== compiler/GHC/StgToCmm/Prof.hs ===================================== @@ -166,7 +166,7 @@ profDynAlloc rep ccs = ifProfiling $ do profile <- getProfile let platform = profilePlatform profile - profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs + profAlloc (mkIntExpr platform (toTargetInt (heapClosureSizeW profile rep))) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -182,7 +182,7 @@ profAlloc words ccs (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] + [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (toTargetInt (profHdrSize profile))]] ) -- ----------------------------------------------------------------------- @@ -224,7 +224,7 @@ emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do { ctx <- stgToCmmContext <$> getStgToCmmConfig ; platform <- getPlatform - ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF + ; let is_caf | isCafCC cc = mkIntCLit platform (toTargetInt (ord 'c')) -- 'c' == is a CAF | otherwise = zero platform -- NB. bytesFS: we want the UTF-8 bytes here (#5559) ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) @@ -347,7 +347,7 @@ dynLdvInit :: Platform -> CmmExpr dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [ - CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], + CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (toTargetInt (pc_LDV_SHIFT (platformConstants platform)))], CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ] @@ -390,7 +390,7 @@ ldvEnterClosure closure_info node_reg = do platform <- getPlatform let tag = funTag platform closure_info -- don't forget to subtract node's tag - ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) + ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-(fromDynTag tag))) ldvEnter :: CmmExpr -> FCode () -- 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 = -- before, but the code generator wasn't handling that -- properly and it led to chaos, panic and disorder. [ zeroCLit platform, -- registered? - mkIntCLit platform arity, -- Arity + mkIntCLit platform (toTargetInt arity), -- Arity zeroCLit platform, -- Heap allocated for this thing fun_desc, arg_desc, @@ -848,7 +848,7 @@ bumpHistogram lbl n = do emitAddToMem :: CmmExpr -> Int -> FCode () emitAddToMem lhs n = do platform <- getPlatform - emitAddToMemE lhs (mkIntExpr platform n) + emitAddToMemE lhs (mkIntExpr platform (toTargetInt n)) emitAddToMemE :: CmmExpr -> CmmExpr -> FCode () emitAddToMemE lhs n = do ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -160,7 +160,7 @@ mkTaggedObjectLoad platform reg base offset tag = mkAssign (CmmLocal reg) (CmmLoad (cmmOffsetB platform (CmmReg (CmmLocal base)) - (offset - tag)) + (offset - fromDynTag tag)) (localRegType reg) NaturallyAligned) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2367,8 +2367,9 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) -- The two-step process avoids getting two errors: one from -- the expression itself, and one from the 'print it' part -- This two-step story is very clunky, alas - , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + , do { _ <- checkNoErrs (discardWarnings (tcGhciStmts [let_stmt])) --- checkNoErrs defeats the error recovery of let-bindings + --- discardWarnings: warnings come from the second typecheck ; tcGhciStmts [let_stmt, print_it] } ] -- 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. :category: Use the package environment in ⟨file⟩, or in - ``$XDG_DATA_HOME/ghc/arch-os-version/environments/⟨name⟩`` + ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/⟨name⟩`` If set to ``-`` no package environment is read. .. envvar:: GHC_ENVIRONMENT @@ -613,13 +613,13 @@ locations: - File ⟨file⟩ if you pass the option :ghc-flag:`-package-env ⟨file⟩|⟨name⟩`. -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if you pass the +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if you pass the option ``-package-env ⟨name⟩``. - File ⟨file⟩ if the environment variable :envvar:`GHC_ENVIRONMENT` is set to ⟨file⟩. -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/name`` if the +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/name`` if the environment variable :envvar:`GHC_ENVIRONMENT` is set to ⟨name⟩. Additionally, unless ``-hide-all-packages`` is specified ``ghc`` will also @@ -628,7 +628,7 @@ look for the package environment in the following locations: - File ``.ghc.environment.arch-os-version`` if it exists in the current directory or any parent directory (but not the user's home directory). -- File ``$XDG_DATA_HOME/ghc/arch-os-version/environments/default`` if it +- File ``$XDG_DATA_HOME/.ghc/arch-os-version/environments/default`` if it exists. Package environments can be modified by further command line arguments; ===================================== testsuite/tests/deSugar/should_compile/T25996.hs ===================================== @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +main :: IO () +main = do + pure () + where + biz :: IO () + biz = do + pure (10 :: Integer) + pure () + +biz' :: IO () +biz' = do + pure (10 :: Integer) + pure () ===================================== testsuite/tests/deSugar/should_compile/T25996.stderr ===================================== @@ -0,0 +1,10 @@ +T25996.hs:11:7: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + A do-notation statement discarded a result of type ‘Integer’ + Suggested fix: + Suppress this warning by saying ‘_ <- pure (10 :: Integer)’ + +T25996.hs:16:3: warning: [GHC-81995] [-Wunused-do-bind (in -Wall)] + A do-notation statement discarded a result of type ‘Integer’ + Suggested fix: + Suppress this warning by saying ‘_ <- pure (10 :: Integer)’ + ===================================== testsuite/tests/deSugar/should_compile/all.T ===================================== @@ -115,3 +115,4 @@ test('T19883', normal, compile, ['']) test('T22719', normal, compile, ['-ddump-simpl -dsuppress-uniques -dno-typeable-binds']) test('T23550', normal, compile, ['']) test('T24489', normal, compile, ['-O']) +test('T25996', normal, compile, ['']) ===================================== testsuite/tests/ghci/scripts/T26233.script ===================================== @@ -0,0 +1,2 @@ +:set -Wall +truncate pi ===================================== testsuite/tests/ghci/scripts/T26233.stderr ===================================== @@ -0,0 +1,14 @@ +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)] + • Defaulting the type variable ‘a0’ to type ‘Double’ in the following constraints + (RealFrac a0) + arising from a use of ‘truncate’ at <interactive>:2:1-8 + (Floating a0) arising from a use of ‘pi’ at <interactive>:2:10-11 + • In the expression: truncate pi + In an equation for ‘it’: it = truncate pi + +<interactive>:2:1: warning: [GHC-18042] [-Wtype-defaults (in -Wall)] + • Defaulting the type variable ‘a0’ to type ‘Integer’ in the following constraints + (Show a0) arising from a use of ‘print’ at <interactive>:2:1-11 + (Integral a0) arising from a use of ‘it’ at <interactive>:2:1-11 + • In a stmt of an interactive GHCi command: print it + ===================================== testsuite/tests/ghci/scripts/T26233.stdout ===================================== @@ -0,0 +1 @@ +3 ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -391,3 +391,4 @@ test('GhciPackageRename', [extra_hc_opts("-hide-all-packages -package 'containers (Data.Map as Prelude)'")], ghci_script, ['GhciPackageRename.script']) +test('T26233', normal, ghci_script, ['T26233.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/736cb42dd897b68f40fe71aa653df04... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/736cb42dd897b68f40fe71aa653df04... You're receiving this email because of your account on gitlab.haskell.org.