From gitlab at gitlab.haskell.org Mon Jan 1 11:55:42 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 01 Jan 2024 06:55:42 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: StgToCmm: Detect some no-op case-continuations Message-ID: <6592a83e39a9f_2981392724537093446@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: bc4d67b7 by Matthew Craven at 2023-12-31T06:15:42-05:00 StgToCmm: Detect some no-op case-continuations ...and generate no code for them. Fixes #24264. - - - - - 5b603139 by Krzysztof Gogolewski at 2023-12-31T06:16:18-05:00 Revert "testsuite: mark jspace as fragile on i386." This reverts commit 0038d052c8c80b4b430bb2aa1c66d5280be1aa95. The atomicity bug should be fixed by !11802. - - - - - 2cfb3828 by Krzysztof Gogolewski at 2024-01-01T06:54:54-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 8d4c5048 by Ömer Sinan Ağacan at 2024-01-01T06:55:03-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - 11 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToCmm/Expr.hs - docs/users_guide/exts/kind_signatures.rst - + testsuite/tests/codeGen/should_compile/T24264.hs - + testsuite/tests/codeGen/should_compile/T24264.stderr - testsuite/tests/codeGen/should_compile/all.T - + testsuite/tests/codeGen/should_run/T24264run.hs - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/driver/j-space/all.T Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic import Control.Monad (ap) -import Data.Maybe (fromMaybe) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -531,8 +530,10 @@ coreToStgApp f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc - | saturated -> StgConApp dc NoNumber args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + | saturated -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber args' (sumPrimReps args) + else + StgConApp dc NoNumber args' [] -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps @@ -560,6 +561,16 @@ coreToStgApp f args ticks = do -- profiling for #4367 app `seq` return tapp + +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -310,7 +310,7 @@ for the details of this transformation. | StgConApp DataCon ConstructorNumber [StgArg] -- Saturated. See Note [Constructor applications in STG] - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -166,8 +166,8 @@ avoid #19645. Other alternatives considered include: way to fix what is ultimately a corner-case. -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term: (# 123 | #) @@ -180,9 +180,21 @@ type of this term. For example, these are all valid tuples for this: (# 1#, 123, rubbish, rubbish #) -- when type is (# Int | (# Int, Int, Int #) #) -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. + +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. Note [Casting slot arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -527,7 +539,7 @@ unariseExpr rho (StgConApp dc n args ty_args) -> return $ (mkTuple args') | otherwise = let args' = unariseConArgs rho args in - return $ (StgConApp dc n args' (map stgArgType args')) + return $ (StgConApp dc n args' []) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -572,7 +584,7 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] -> ( [OutStgArg] -- Arguments representing the unboxed sum , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them -- into the right Rep @@ -860,7 +872,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- -- Example, for (# x | #) :: (# (# #) | Int #) we call -- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] -- -- which returns -- @@ -869,7 +881,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = mkUbxSum :: HasDebugCallStack => DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments @@ -877,7 +889,7 @@ mkUbxSum ) mkUbxSum dc ty_args args0 us = let - _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) tag = dataConTag dc @@ -1121,7 +1133,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] tagAltTy :: AltType tagAltTy = PrimAlt IntRep ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -570,6 +570,58 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts -- Use the same return convention as vanilla 'a'. cgCase (StgApp a []) bndr alt_type alts +{- +Note [Eliminate trivial Solo# continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have code like this: + + case scrut of bndr { + alt -> Solo# bndr + } + +The RHS of the only branch does nothing except wrap the case-binder +returned by 'scrut' in a unary unboxed tuple. But unboxed tuples +don't exist at run-time, i.e. the branch is a no-op! So we can +generate code as if we just had 'scrut' instead of a case-expression. + +This situation can easily arise for IO or ST code, where the last +operation a function performs is commonly 'pure $! someExpr'. +See also #24264 and !11778. More concretely, as of December 2023, +when building a stage2 "perf+no_profiled_libs" ghc: + + * The special case is reached 398 times. + * Of these, 158 have scrutinees that call a function or enter a + potential thunk, and would need to push a useless stack frame if + not for this optimisation. + +We might consider rewriting such case expressions in GHC.Stg.CSE as a +slight extension of Note [All alternatives are the binder]. But the +RuntimeReps of 'bndr' and 'Solo# bndr' are not exactly the same, and +per Note [Typing the STG language] in GHC.Stg.Lint, we do expect Stg +code to remain RuntimeRep-correct. So we just detect the situation in +StgToCmm instead. + +Crucially, the return conventions for 'ty' and '(# ty #)' are compatible: +The returned value is passed in the same register(s) or stack slot in +both conventions, and the set of allowed return values for 'ty' +is a subset of the allowed return values for '(# ty #)': + + * For a lifted type 'ty', the return convention for 'ty' promises to + return an evaluated-properly-tagged heap pointer, while a return + type '(# ty #)' only promises to return a heap pointer to an object + that can be evaluated later if need be. + + * If 'ty' is unlifted, the allowed return + values for 'ty' and '(# ty #)' are identical. +-} + +cgCase scrut bndr _alt_type [GenStgAlt { alt_rhs = rhs}] + -- see Note [Eliminate trivial Solo# continuations] + | StgConApp dc _ [StgVarArg v] _ <- rhs + , isUnboxedTupleDataCon dc + , v == bndr + = cgExpr scrut + cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== docs/users_guide/exts/kind_signatures.rst ===================================== @@ -37,6 +37,10 @@ This extension enables kind signatures in the following places: data Set (cxt :: Type -> Type) a = Set [a] +- ``newtype`` declarations: :: + + newtype Set (cxt :: Type -> Type) a = Set [a] + - ``type`` declarations: :: type T (f :: Type -> Type) = f Int ===================================== testsuite/tests/codeGen/should_compile/T24264.hs ===================================== @@ -0,0 +1,42 @@ +{-# LANGUAGE MagicHash #-} + +module T24264 where + +import Control.Exception (evaluate) +import GHC.Exts (seq#, noinline) +import GHC.IO (IO(..)) + +fun1 :: a -> IO a +{-# OPAQUE fun1 #-} +fun1 x = do + pure () + pure $! x + -- This should not push a continuation to the stack before entering 'x' + +fun2 :: a -> IO a +{-# OPAQUE fun2 #-} +fun2 x = do + pure () + evaluate x + -- This should not push a continuation to the stack before entering 'x' + +fun3 :: a -> IO a +{-# OPAQUE fun3 #-} +fun3 x = do + pure () + -- "evaluate $! x" + case x of !x' -> IO (noinline seq# x') + -- noinline to work around the bogus seqRule + -- This ideally also should not push a continuation to the stack + -- before entering 'x'. It currently does, but let's wait for + -- !11515 to land before worrying about that. + +funPair :: a -> IO (a, a) +{-# OPAQUE funPair #-} +funPair x = do + pure () + x' <- pure $! x + -- This should push a continuation to the stack before entering 'x', + -- so the pair can be returned instead. (It's here to make sure + -- that the 'returns to' detection continues working correctly.) + pure (x', x') ===================================== testsuite/tests/codeGen/should_compile/T24264.stderr ===================================== @@ -0,0 +1,142 @@ + +==================== Cmm produced by codegen ==================== +[T24264.fun1_entry() { // [R2] + { info_tbls: [(cQO, + label: T24264.fun1_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cQO: // global + _sQw::P64 = R2; // CmmAssign + goto cQM; // CmmBranch + cQM: // global + if ((old + 0) - < SpLim) (likely: False) goto cQP; else goto cQQ; // CmmCondBranch + cQP: // global + R2 = _sQw::P64; // CmmAssign + R1 = T24264.fun1_closure; // CmmAssign + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + cQQ: // global + goto cQL; // CmmBranch + cQL: // global + // slowCall + R1 = _sQw::P64; // CmmAssign + call stg_ap_0_fast(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }] + + + +==================== Cmm produced by codegen ==================== +[T24264.fun2_entry() { // [R2] + { info_tbls: [(cQY, + label: T24264.fun2_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cQY: // global + _sQz::P64 = R2; // CmmAssign + goto cQW; // CmmBranch + cQW: // global + if ((old + 0) - < SpLim) (likely: False) goto cQZ; else goto cR0; // CmmCondBranch + cQZ: // global + R2 = _sQz::P64; // CmmAssign + R1 = T24264.fun2_closure; // CmmAssign + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + cR0: // global + goto cQV; // CmmBranch + cQV: // global + // slowCall + R1 = _sQz::P64; // CmmAssign + call stg_ap_0_fast(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }] + + + +==================== Cmm produced by codegen ==================== +[T24264.fun3_entry() { // [R2] + { info_tbls: [(cRb, + label: T24264.fun3_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cRb: // global + _sQB::P64 = R2; // CmmAssign + goto cR6; // CmmBranch + cR6: // global + if ((old + 0) - < SpLim) (likely: False) goto cRc; else goto cRd; // CmmCondBranch + cRc: // global + R2 = _sQB::P64; // CmmAssign + R1 = T24264.fun3_closure; // CmmAssign + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + cRd: // global + goto cR5; // CmmBranch + cR5: // global + // slowCall + I64[(young + 8)] = cR8; // CmmStore + R1 = _sQB::P64; // CmmAssign + call stg_ap_0_fast(R1) returns to cR8, args: 8, res: 8, upd: 8; // CmmCall + cR8: // global + _sQD::P64 = R1; // CmmAssign + // slow_call for _sQB::P64 with pat stg_ap_0 + R1 = _sQD::P64; // CmmAssign + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }] + + + +==================== Cmm produced by codegen ==================== +[T24264.funPair_entry() { // [R2] + { info_tbls: [(cRq, + label: T24264.funPair_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cRq: // global + _sQE::P64 = R2; // CmmAssign + goto cRl; // CmmBranch + cRl: // global + if ((old + 0) - < SpLim) (likely: False) goto cRr; else goto cRs; // CmmCondBranch + cRr: // global + R2 = _sQE::P64; // CmmAssign + R1 = T24264.funPair_closure; // CmmAssign + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + cRs: // global + goto cRk; // CmmBranch + cRk: // global + // slowCall + I64[(young + 8)] = cRn; // CmmStore + R1 = _sQE::P64; // CmmAssign + call stg_ap_0_fast(R1) returns to cRn, args: 8, res: 8, upd: 8; // CmmCall + cRn: // global + _sQG::P64 = R1; // CmmAssign + // slow_call for _sQE::P64 with pat stg_ap_0 + Hp = Hp + 24; // CmmAssign + if (Hp > HpLim) (likely: False) goto cRv; else goto cRu; // CmmCondBranch + cRv: // global + HpAlloc = 24; // CmmAssign + goto cRt; // CmmBranch + cRt: // global + R1 = _sQG::P64; // CmmAssign + call stg_gc_unpt_r1(R1) returns to cRn, args: 8, res: 8, upd: 8; // CmmCall + cRu: // global + // allocHeapClosure + I64[Hp - 16] = (,)_con_info; // CmmStore + P64[Hp - 8] = _sQG::P64; // CmmStore + P64[Hp] = _sQG::P64; // CmmStore + _cRp::P64 = Hp - 15; // CmmAssign + R1 = _cRp::P64; // CmmAssign + call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }] + + ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -128,3 +128,5 @@ test('T21710a', [ unless(tables_next_to_code(), skip) , when(wordsize(32), skip) , grep_errmsg('(call)',[1]) ] , compile, ['-ddump-cmm -dno-typeable-binds']) test('T23002', normal, compile, ['-fregs-graph']) +test('T24264', [req_cmm, grep_errmsg(r'(.*\().*(\) returns to)', [1,2])], + compile, ['-O -ddump-cmm-from-stg -dno-typeable-binds']) ===================================== testsuite/tests/codeGen/should_run/T24264run.hs ===================================== @@ -0,0 +1,32 @@ +module Main where + +import Control.Exception (evaluate) +import GHC.Exts (lazy, noinline) + +data StrictPair a b = !a :*: !b + +tailEval1 :: a -> IO a +{-# OPAQUE tailEval1 #-} +tailEval1 = lazy $ \x -> do + pure () + pure $! x + +tailEval2 :: a -> IO a +{-# OPAQUE tailEval2 #-} +tailEval2 x = evaluate x + +go :: [a] -> IO () +go = noinline mapM_ $ \x -> do + y1 <- tailEval1 x + y2 <- tailEval2 x + evaluate (y1 :*: y2) + +main :: IO () +main = do + let ints :: [Int] + ints = take 1000 $ noinline iterate (\x -> x * 35) 1 + go ints + go [LT, EQ, GT] + go $ noinline map (toEnum @Ordering . flip mod 3) ints + go $ noinline map Left ints + go $ noinline map (+) ints ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -240,3 +240,4 @@ test('MulMayOflo_full', ignore_stdout], multi_compile_and_run, ['MulMayOflo', [('MulMayOflo_full.cmm', '')], '']) +test('T24264run', normal, compile_and_run, ['']) ===================================== testsuite/tests/driver/j-space/all.T ===================================== @@ -1 +1 @@ -test('jspace', [extra_files(['genJspace']), req_target_smp, req_ghc_smp, js_broken(22573),when(arch('i386'), fragile(24261))], makefile_test, ['jspace']) +test('jspace', [extra_files(['genJspace']), req_target_smp, req_ghc_smp, js_broken(22573)], makefile_test, ['jspace']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8cf80131a6ad5d60114879db17738be445e07075...8d4c5048b555654c6ce1ae0037eb6f4092afc59f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8cf80131a6ad5d60114879db17738be445e07075...8d4c5048b555654c6ce1ae0037eb6f4092afc59f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 1 14:36:22 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 01 Jan 2024 09:36:22 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/type-prim-rep-args Message-ID: <6592cde690d0b_2981392aebf9e010387a@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/type-prim-rep-args at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/type-prim-rep-args You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 1 14:45:49 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 01 Jan 2024 09:45:49 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Refactor: store [[PrimRep]] rather than [Type] in STG Message-ID: <6592d01d93207_2981392b7284381068a2@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 76f285e3 by Krzysztof Gogolewski at 2024-01-01T09:45:42-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - efe9bca3 by Ömer Sinan Ağacan at 2024-01-01T09:45:44-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - 4 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - docs/users_guide/exts/kind_signatures.rst Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic import Control.Monad (ap) -import Data.Maybe (fromMaybe) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -531,8 +530,10 @@ coreToStgApp f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc - | saturated -> StgConApp dc NoNumber args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + | saturated -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber args' (sumPrimReps args) + else + StgConApp dc NoNumber args' [] -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps @@ -560,6 +561,16 @@ coreToStgApp f args ticks = do -- profiling for #4367 app `seq` return tapp + +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -310,7 +310,7 @@ for the details of this transformation. | StgConApp DataCon ConstructorNumber [StgArg] -- Saturated. See Note [Constructor applications in STG] - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -166,8 +166,8 @@ avoid #19645. Other alternatives considered include: way to fix what is ultimately a corner-case. -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term: (# 123 | #) @@ -180,9 +180,21 @@ type of this term. For example, these are all valid tuples for this: (# 1#, 123, rubbish, rubbish #) -- when type is (# Int | (# Int, Int, Int #) #) -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. + +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. Note [Casting slot arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -527,7 +539,7 @@ unariseExpr rho (StgConApp dc n args ty_args) -> return $ (mkTuple args') | otherwise = let args' = unariseConArgs rho args in - return $ (StgConApp dc n args' (map stgArgType args')) + return $ (StgConApp dc n args' []) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -572,7 +584,7 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] -> ( [OutStgArg] -- Arguments representing the unboxed sum , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them -- into the right Rep @@ -860,7 +872,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- -- Example, for (# x | #) :: (# (# #) | Int #) we call -- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] -- -- which returns -- @@ -869,7 +881,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = mkUbxSum :: HasDebugCallStack => DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments @@ -877,7 +889,7 @@ mkUbxSum ) mkUbxSum dc ty_args args0 us = let - _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) tag = dataConTag dc @@ -1121,7 +1133,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] tagAltTy :: AltType tagAltTy = PrimAlt IntRep ===================================== docs/users_guide/exts/kind_signatures.rst ===================================== @@ -37,6 +37,10 @@ This extension enables kind signatures in the following places: data Set (cxt :: Type -> Type) a = Set [a] +- ``newtype`` declarations: :: + + newtype Set (cxt :: Type -> Type) a = Set [a] + - ``type`` declarations: :: type T (f :: Type -> Type) = f Int View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d4c5048b555654c6ce1ae0037eb6f4092afc59f...efe9bca30f7f989d28485332434f4ea236e57111 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d4c5048b555654c6ce1ae0037eb6f4092afc59f...efe9bca30f7f989d28485332434f4ea236e57111 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 1 17:06:31 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 01 Jan 2024 12:06:31 -0500 Subject: [Git][ghc/ghc][master] Refactor: store [[PrimRep]] rather than [Type] in STG Message-ID: <6592f117346c6_2981392eb1183012165e@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d55216ad by Krzysztof Gogolewski at 2024-01-01T12:05:49-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 3 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs Changes: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic import Control.Monad (ap) -import Data.Maybe (fromMaybe) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -531,8 +530,10 @@ coreToStgApp f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc - | saturated -> StgConApp dc NoNumber args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + | saturated -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber args' (sumPrimReps args) + else + StgConApp dc NoNumber args' [] -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps @@ -560,6 +561,16 @@ coreToStgApp f args ticks = do -- profiling for #4367 app `seq` return tapp + +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -310,7 +310,7 @@ for the details of this transformation. | StgConApp DataCon ConstructorNumber [StgArg] -- Saturated. See Note [Constructor applications in STG] - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -166,8 +166,8 @@ avoid #19645. Other alternatives considered include: way to fix what is ultimately a corner-case. -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term: (# 123 | #) @@ -180,9 +180,21 @@ type of this term. For example, these are all valid tuples for this: (# 1#, 123, rubbish, rubbish #) -- when type is (# Int | (# Int, Int, Int #) #) -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. + +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. Note [Casting slot arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -527,7 +539,7 @@ unariseExpr rho (StgConApp dc n args ty_args) -> return $ (mkTuple args') | otherwise = let args' = unariseConArgs rho args in - return $ (StgConApp dc n args' (map stgArgType args')) + return $ (StgConApp dc n args' []) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -572,7 +584,7 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] -> ( [OutStgArg] -- Arguments representing the unboxed sum , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them -- into the right Rep @@ -860,7 +872,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- -- Example, for (# x | #) :: (# (# #) | Int #) we call -- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] -- -- which returns -- @@ -869,7 +881,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = mkUbxSum :: HasDebugCallStack => DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments @@ -877,7 +889,7 @@ mkUbxSum ) mkUbxSum dc ty_args args0 us = let - _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) tag = dataConTag dc @@ -1121,7 +1133,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] tagAltTy :: AltType tagAltTy = PrimAlt IntRep View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d55216ad61f0bb4705c6408b59a1541460e63af3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d55216ad61f0bb4705c6408b59a1541460e63af3 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 1 17:07:10 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 01 Jan 2024 12:07:10 -0500 Subject: [Git][ghc/ghc][master] Kind signatures docs: mention that they're allowed in newtypes Message-ID: <6592f13ed80a4_2981392eafa7c0124522@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 8b340bc7 by Ömer Sinan Ağacan at 2024-01-01T12:06:29-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - 1 changed file: - docs/users_guide/exts/kind_signatures.rst Changes: ===================================== docs/users_guide/exts/kind_signatures.rst ===================================== @@ -37,6 +37,10 @@ This extension enables kind signatures in the following places: data Set (cxt :: Type -> Type) a = Set [a] +- ``newtype`` declarations: :: + + newtype Set (cxt :: Type -> Type) a = Set [a] + - ``type`` declarations: :: type T (f :: Type -> Type) = f Int View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b340bc73c4d77ba312a6390335ba50fb5104004 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b340bc73c4d77ba312a6390335ba50fb5104004 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue Jan 2 17:12:56 2024 From: gitlab at gitlab.haskell.org (John Ericson (@Ericson2314)) Date: Tue, 02 Jan 2024 12:12:56 -0500 Subject: [Git][ghc/ghc][wip/hadrian-ghc-llvm-version] 175 commits: EPA Some tweaks to annotations Message-ID: <6594441890f38_1a276858fdbd01067e9@gitlab.mail> John Ericson pushed to branch wip/hadrian-ghc-llvm-version at Glasgow Haskell Compiler / GHC Commits: de78b32a by Alan Zimmerman at 2023-10-23T09:09:41-04:00 EPA Some tweaks to annotations - Fix span for GRHS - Move TrailingAnns from last match to FunBind - Fix GADT 'where' clause span - Capture full range for a CaseAlt Match - - - - - d5a8780d by Simon Hengel at 2023-10-23T09:10:23-04:00 Update primitives.rst - - - - - 4d075924 by Josh Meredith at 2023-10-24T23:04:12+11:00 JS/userguide: add explanation of writing jsbits - - - - - 07ab5cc1 by Cheng Shao at 2023-10-24T15:40:32-04:00 testsuite: increase timeout of ghc-api tests for wasm32 ghc-api tests for wasm32 are more likely to timeout due to the large wasm module sizes, especially when testing with wasm native tail calls, given wasmtime's handling of tail call opcodes are suboptimal at the moment. It makes sense to increase timeout specifically for these tests on wasm32. This doesn't affect other targets, and for wasm32 we don't increase timeout for all tests, so not to risk letting major performance regressions slip through the testsuite. - - - - - 0d6acca5 by Greg Steuck at 2023-10-26T08:44:23-04:00 Explicitly require RLIMIT_AS before use in OSMem.c This is done elsewhere in the source tree. It also suddenly is required on OpenBSD. - - - - - 9408b086 by Sylvain Henry at 2023-10-26T08:45:03-04:00 Modularity: modularize external linker Decouple runLink from DynFlags to allow calling runLink more easily. This is preliminary work for calling Emscripten's linker (emcc) from our JavaScript linker. - - - - - e0f35030 by doyougnu at 2023-10-27T08:41:12-04:00 js: add JStg IR, remove unsaturated constructor - Major step towards #22736 and adding the optimizer in #22261 - - - - - 35587eba by Simon Peyton Jones at 2023-10-27T08:41:48-04:00 Fix a bug in tail calls with ticks See #24078 for the diagnosis. The change affects only the Tick case of occurrence analysis. It's a bit hard to test, so no regression test (yet anyway). - - - - - 9bc5cb92 by Matthew Craven at 2023-10-28T07:06:17-04:00 Teach tag-inference about SeqOp/seq# Fixes the STG/tag-inference analogue of #15226. Co-Authored-By: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 34f06334 by Moritz Angermann at 2023-10-28T07:06:53-04:00 [PEi386] Mask SYM_TYPE_DUP_DISCARD in makeSymbolExtra 48e391952c17ff7eab10b0b1456e3f2a2af28a9b introduced `SYM_TYPE_DUP_DISCARD` to the bitfield. The linker however, failed to mask the `SYM_TYPE_DUP_DISCARD` value. Thus `== SYM_TYPE_CODE` comparisons easily failed. This lead to us relocating DATA lookups (GOT) into E8 (call) and E9 (jump) instructions. - - - - - 5b51b2a2 by Mario Blažević at 2023-10-28T07:07:33-04:00 Fix and test for issue #24111, TH.Ppr output of pattern synonyms - - - - - 723bc352 by Alan Zimmerman at 2023-10-30T20:36:41-04:00 EPA: print doc comments as normal comments And ignore the ones allocated in haddock processing. It does not guarantee that every original haddock-like comment appears in the output, as it discards ones that have no legal attachment point. closes #23459 - - - - - 21b76843 by Simon Peyton Jones at 2023-10-30T20:37:17-04:00 Fix non-termination bug in equality solver constraint left-to-right then right to left, forever. Easily fixed. - - - - - 270867ac by Sebastian Graf at 2023-10-30T20:37:52-04:00 ghc-toolchain: build with `-package-env=-` (#24131) Otherwise globally installed libraries (via `cabal install --lib`) break the build. Fixes #24131. - - - - - 7a90020f by Krzysztof Gogolewski at 2023-10-31T20:03:37-04:00 docs: fix ScopedTypeVariables example (#24101) The previous example didn't compile. Furthermore, it wasn't demonstrating the point properly. I have changed it to an example which shows that 'a' in the signature must be the same 'a' as in the instance head. - - - - - 49f69f50 by Krzysztof Gogolewski at 2023-10-31T20:04:13-04:00 Fix pretty-printing of type family dependencies "where" should be after the injectivity annotation. - - - - - 73c191c0 by Ben Gamari at 2023-10-31T20:04:49-04:00 gitlab-ci: Bump LLVM bootstrap jobs to Debian 12 As the Debian 10 images have too old an LLVM. Addresses #24056. - - - - - 5b0392e0 by Matthew Pickering at 2023-10-31T20:04:49-04:00 ci: Run aarch64 llvm backend job with "LLVM backend" label This brings it into line with the x86 LLVM backend job. - - - - - 9f9c9227 by Ryan Scott at 2023-11-01T09:19:12-04:00 More robust checking for DataKinds As observed in #22141, GHC was not doing its due diligence in catching code that should require `DataKinds` in order to use. Most notably, it was allowing the use of arbitrary data types in kind contexts without `DataKinds`, e.g., ```hs data Vector :: Nat -> Type -> Type where ``` This patch revamps how GHC tracks `DataKinds`. The full specification is written out in the `DataKinds` section of the GHC User's Guide, and the implementation thereof is described in `Note [Checking for DataKinds]` in `GHC.Tc.Validity`. In brief: * We catch _type_-level `DataKinds` violations in the renamer. See `checkDataKinds` in `GHC.Rename.HsType` and `check_data_kinds` in `GHC.Rename.Pat`. * We catch _kind_-level `DataKinds` violations in the typechecker, as this allows us to catch things that appear beneath type synonyms. (We do *not* want to do this in type-level contexts, as it is perfectly fine for a type synonym to mention something that requires DataKinds while still using the type synonym in a module that doesn't enable DataKinds.) See `checkValidType` in `GHC.Tc.Validity`. * There is now a single `TcRnDataKindsError` that classifies all manner of `DataKinds` violations, both in the renamer and the typechecker. The `NoDataKindsDC` error has been removed, as it has been subsumed by `TcRnDataKindsError`. * I have added `CONSTRAINT` is `isKindTyCon`, which is what checks for illicit uses of data types at the kind level without `DataKinds`. Previously, `isKindTyCon` checked for `Constraint` but not `CONSTRAINT`. This is inconsistent, given that both `Type` and `TYPE` were checked by `isKindTyCon`. Moreover, it thwarted the implementation of the `DataKinds` check in `checkValidType`, since we would expand `Constraint` (which was OK without `DataKinds`) to `CONSTRAINT` (which was _not_ OK without `DataKinds`) and reject it. Now both are allowed. * I have added a flurry of additional test cases that test various corners of `DataKinds` checking. Fixes #22141. - - - - - 575d7690 by Sylvain Henry at 2023-11-01T09:19:53-04:00 JS: fix FFI "wrapper" and "dynamic" Fix codegen and helper functions for "wrapper" and "dynamic" foreign imports. Fix tests: - ffi006 - ffi011 - T2469 - T4038 Related to #22363 - - - - - 81fb8885 by Alan Zimmerman at 2023-11-01T22:23:56-04:00 EPA: Use full range for Anchor This change requires a series of related changes, which must all land at the same time, otherwise all the EPA tests break. * Use the current Anchor end as prior end Use the original anchor location end as the source of truth for calculating print deltas. This allows original spacing to apply in most cases, only changed AST items need initial delta positions. * Add DArrow to TrailingAnn * EPA Introduce HasTrailing in ExactPrint Use [TrailingAnn] in enterAnn and remove it from ExactPrint (LocatedN RdrName) * In HsDo, put TrailingAnns at top of LastStmt * EPA: do not convert comments to deltas when balancing. * EPA: deal with fallout from getMonoBind * EPA fix captureLineSpacing * EPA print any comments in the span before exiting it * EPA: Add comments to AnchorOperation * EPA: remove AnnEofComment, it is no longer used Updates Haddock submodule - - - - - 03e82511 by Rodrigo Mesquita at 2023-11-01T22:24:32-04:00 Fix in docs regarding SSymbol, SNat, SChar (#24119) - - - - - 362cc693 by Matthew Pickering at 2023-11-01T22:25:08-04:00 hadrian: Update bootstrap plans (9.4.6, 9.4.7, 9.6.2, 9.6.3, 9.8.1) Updating the bootstrap plans with more recent GHC versions. - - - - - 00b9b8d3 by Matthew Pickering at 2023-11-01T22:25:08-04:00 ci: Add 9.8.1 bootstrap testing job - - - - - ef3d20f8 by Matthew Pickering at 2023-11-01T22:25:08-04:00 Compatibility with 9.8.1 as boot compiler This fixes several compatability issues when using 9.8.1 as the boot compiler. * An incorrect version guard on the stack decoding logic in ghc-heap * Some ghc-prim bounds need relaxing * ghc is no longer wired in, so we have to remove the -this-unit-id ghc call. Fixes #24077 - - - - - 6755d833 by Jaro Reinders at 2023-11-03T10:54:42+01:00 Add NCG support for common 64bit operations to the x86 backend. These used to be implemented via C calls which was obviously quite bad for performance for operations like simple addition. Co-authored-by: Andreas Klebinger - - - - - 0dfb1fa7 by Vladislav Zavialov at 2023-11-03T14:08:41-04:00 T2T in Expressions (#23738) This patch implements the T2T (term-to-type) transformation in expressions. Given a function with a required type argument vfun :: forall a -> ... the user can now call it as vfun (Maybe Int) instead of vfun (type (Maybe Int)) The Maybe Int argument is parsed and renamed as a term (HsExpr), but then undergoes a conversion to a type (HsType). See the new function expr_to_type in compiler/GHC/Tc/Gen/App.hs and Note [RequiredTypeArguments and the T2T mapping] Left as future work: checking for puns. - - - - - cc1c7c54 by Duncan Coutts at 2023-11-05T00:23:44-04:00 Add a test for I/O managers It tries to cover the cases of multiple threads waiting on the same fd for reading and multiple threads waiting for writing, including wait cancellation by async exceptions. It should work for any I/O manager, in-RTS or in-Haskell. Unfortunately it will not currently work for Windows because it relies on anonymous unix sockets. It could in principle be ported to use Windows named pipes. - - - - - 2e448f98 by Cheng Shao at 2023-11-05T00:23:44-04:00 Skip the IOManager test on wasm32 arch. The test relies on the sockets API which are not (yet) available. - - - - - fe50eb35 by Cheng Shao at 2023-11-05T00:24:20-04:00 compiler: fix eager blackhole symbol in wasm32 NCG - - - - - af771148 by Cheng Shao at 2023-11-05T00:24:20-04:00 testsuite: fix optasm tests for wasm32 - - - - - 1b90735c by Matthew Pickering at 2023-11-05T00:24:20-04:00 testsuite: Add wasm32 to testsuite arches with NCG The compiler --info reports that wasm32 compilers have a NCG, so we should agree with that here. - - - - - db9a6496 by Alan Zimmerman at 2023-11-05T00:24:55-04:00 EPA: make locA a function, not a field name And use it to generalise reLoc The following for the windows pipeline one. 5.5% Metric Increase: T5205 - - - - - 833e250c by Simon Peyton Jones at 2023-11-05T00:25:31-04:00 Update the unification count in wrapUnifierX Omitting this caused type inference to fail in #24146. This was an accidental omision in my refactoring of the equality solver. - - - - - e451139f by Andreas Klebinger at 2023-11-05T00:26:07-04:00 Remove an accidental git conflict marker from a comment. - - - - - 30baac7a by Tobias Haslop at 2023-11-06T10:50:32+00:00 Add laws relating between Foldable/Traversable with their Bi- superclasses See https://github.com/haskell/core-libraries-committee/issues/205 for discussion. This commit also documents that the tuple instances only satisfy the laws up to lazyness, similar to the documentation added in !9512. - - - - - df626f00 by Tobias Haslop at 2023-11-07T02:20:37-05:00 Elaborate on the quantified superclass of Bifunctor This was requested in the comment https://github.com/haskell/core-libraries-committee/issues/93#issuecomment-1597271700 for when Traversable becomes a superclass of Bitraversable, but similarly applies to Functor/Bifunctor, which already are in a superclass relationship. - - - - - 8217acb8 by Alan Zimmerman at 2023-11-07T02:21:12-05:00 EPA: get rid of l2l and friends Replace them with l2l to convert the location la2la to convert a GenLocated thing Updates haddock submodule - - - - - dd88a260 by Luite Stegeman at 2023-11-07T02:21:53-05:00 JS: remove broken newIdents from JStg Monad GHC.JS.JStg.Monad.newIdents was broken, resulting in duplicate identifiers being generated in h$c1, h$c2, ... . This change removes the broken newIdents. - - - - - 455524a2 by Matthew Craven at 2023-11-09T08:41:59-05:00 Create specially-solved DataToTag class Closes #20532. This implements CLC proposal 104: https://github.com/haskell/core-libraries-committee/issues/104 The design is explained in Note [DataToTag overview] in GHC.Tc.Instance.Class. This replaces the existing `dataToTag#` primop. These metric changes are not "real"; they represent Unique-related flukes triggering on a different set of jobs than they did previously. See also #19414. Metric Decrease: T13386 T8095 Metric Increase: T13386 T8095 Co-authored-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - a05f4554 by Alan Zimmerman at 2023-11-09T08:42:35-05:00 EPA: get rid of glRR and friends in GHC/Parser.y With the HasLoc and HasAnnotation classes, we can replace a number of type-specific helper functions in the parser with polymorphic ones instead Metric Decrease: MultiLayerModulesTH_Make - - - - - 18498538 by Cheng Shao at 2023-11-09T16:58:12+00:00 ci: bump ci-images for wasi-sdk upgrade - - - - - 52c0fc69 by PHO at 2023-11-09T19:16:22-05:00 Don't assume the current locale is *.UTF-8, set the encoding explicitly primops.txt contains Unicode characters: > LC_ALL=C ./genprimopcode --data-decl < ./primops.txt > genprimopcode: <stdin>: hGetContents: invalid argument (cannot decode byte sequence starting from 226) Hadrian must also avoid using readFile' to read primops.txt because it tries to decode the file with a locale-specific encoding. - - - - - 7233b3b1 by PHO at 2023-11-09T19:17:01-05:00 Use '[' instead of '[[' because the latter is a Bash-ism It doesn't work on platforms where /bin/sh is something other than Bash. - - - - - 6dbab180 by Simon Peyton Jones at 2023-11-09T19:17:36-05:00 Add an extra check in kcCheckDeclHeader_sig Fix #24083 by checking for a implicitly-scoped type variable that is not actually bound. See Note [Disconnected type variables] in GHC.Tc.Gen.HsType For some reason, on aarch64-darwin we saw a 2.8% decrease in compiler allocations for MultiLayerModulesTH_Make; but 0.0% on other architectures. Metric Decrease: MultiLayerModulesTH_Make - - - - - 22551364 by Sven Tennie at 2023-11-11T06:35:22-05:00 AArch64: Delete unused LDATA pseudo-instruction Though there were consuming functions for LDATA, there were no producers. Thus, the removed code was "dead". - - - - - 2a0ec8eb by Alan Zimmerman at 2023-11-11T06:35:59-05:00 EPA: harmonise acsa and acsA in GHC/Parser.y With the HasLoc class, we can remove the acsa helper function, using acsA instead. - - - - - 7ae517a0 by Teo Camarasu at 2023-11-12T08:04:12-05:00 nofib: bump submodule This includes changes that: - fix building a benchmark with HEAD - remove a Makefile-ism that causes errors in bash scripts Resolves #24178 - - - - - 3f0036ec by Alan Zimmerman at 2023-11-12T08:04:47-05:00 EPA: Replace Anchor with EpaLocation An Anchor has a location and an operation, which is either that it is unchanged or that it has moved with a DeltaPos data Anchor = Anchor { anchor :: RealSrcSpan , anchor_op :: AnchorOperation } An EpaLocation also has either a location or a DeltaPos data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) | EpaDelta !DeltaPos ![LEpaComment] Now that we do not care about always having a location in the anchor, we remove Anchor and replace it with EpaLocation We do this with a type alias initially, to ease the transition. The alias will be removed in time. We also have helpers to reconstruct the AnchorOperation from an EpaLocation. This is also temporary. Updates Haddock submodule - - - - - a7492048 by Alan Zimmerman at 2023-11-12T13:43:07+00:00 EPA: get rid of AnchorOperation Now that the Anchor type is an alias for EpaLocation, remove AnchorOperation. Updates haddock submodule - - - - - 0745c34d by Andrew Lelechenko at 2023-11-13T16:25:07-05:00 Add since annotation for showHFloat - - - - - e98051a5 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 Suppress duplicate librares linker warning of new macOS linker Fixes #24167 XCode 15 introduced a new linker which warns on duplicate libraries being linked. To disable this warning, we pass -Wl,-no_warn_duplicate_libraries as suggested by Brad King in CMake issue #25297. This flag isn't necessarily available to other linkers on darwin, so we must only configure it into the CC linker arguments if valid. - - - - - c411c431 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Encoding test witnesses recent iconv bug is fragile A regression in the new iconv() distributed with XCode 15 and MacOS Sonoma causes the test 'encoding004' to fail in the CP936 roundrip. We mark this test as fragile until this is fixed upstream (rather than broken, since previous versions of iconv pass the test) See #24161 - - - - - ce7fe5a9 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Update to LC_ALL=C no longer being ignored in darwin MacOS seems to have fixed an issue where it used to ignore the variable `LC_ALL` in program invocations and default to using Unicode. Since the behaviour seems to be fixed to account for the locale variable, we mark tests that were previously broken in spite of it as fragile (since they now pass in recent macOS distributions) See #24161 - - - - - e6c803f7 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 darwin: Fix single_module is obsolete warning In XCode 15's linker, -single_module is the default and otherwise passing it as a flag results in a warning being raised: ld: warning: -single_module is obsolete This patch fixes this warning by, at configure time, determining whether the linker supports -single_module (which is likely false for all non-darwin linkers, and true for darwin linkers in previous versions of macOS), and using that information at runtime to decide to pass or not the flag in the invocation. Fixes #24168 - - - - - 929ba2f9 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Skip MultiLayerModulesTH_Make on darwin The recent toolchain upgrade on darwin machines resulted in the MultiLayerModulesTH_Make test metrics varying too much from the baseline, ultimately blocking the CI pipelines. This commit skips the test on darwin to temporarily avoid failures due to the environment change in the runners. However, the metrics divergence is being investigated still (tracked in #24177) - - - - - af261ccd by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 configure: check target (not build) understands -no_compact_unwind Previously, we were branching on whether the build system was darwin to shortcut this check, but we really want to branch on whether the target system (which is what we are configuring ld_prog for) is darwin. - - - - - 2125c176 by Luite Stegeman at 2023-11-15T13:19:38-05:00 JS: Fix missing variable declarations The JStg IR update was missing some local variable declarations that were present earlier, causing global variables to be used implicitly (or an error in JavaScript strict mode). This adds the local variable declarations again. - - - - - 99ced73b by Krzysztof Gogolewski at 2023-11-15T13:20:14-05:00 Remove loopy superclass solve mechanism Programs with a -Wloopy-superclass-solve warning will now fail with an error. Fixes #23017 - - - - - 2aff2361 by Zubin Duggal at 2023-11-15T13:20:50-05:00 users-guide: Fix links to libraries from the users-guide. The unit-ids generated in c1a3ecde720b3bddc2c8616daaa06ee324e602ab include the package name, so we don't need to explicitly add it to the links. Fixes #24151 - - - - - 27981fac by Alan Zimmerman at 2023-11-15T13:21:25-05:00 EPA: splitLHsForAllTyInvis does not return ann We did not use the annotations returned from splitLHsForAllTyInvis, so do not return them. - - - - - a6467834 by Krzysztof Gogolewski at 2023-11-15T22:22:59-05:00 Document defaulting of RuntimeReps Fixes #24099 - - - - - 2776920e by Simon Peyton Jones at 2023-11-15T22:23:35-05:00 Second fix to #24083 My earlier fix turns out to be too aggressive for data/type families See wrinkle (DTV1) in Note [Disconnected type variables] - - - - - cee81370 by Sylvain Henry at 2023-11-16T09:57:46-05:00 Fix unusable units and module reexport interaction (#21097) This commit fixes an issue with ModUnusable introduced in df0f148feae. In mkUnusableModuleNameProvidersMap we traverse the list of unusable units and generate ModUnusable origin for all the modules they contain: exposed modules, hidden modules, and also re-exported modules. To do this we have a two-level map: ModuleName -> Unit:ModuleName (aka Module) -> ModuleOrigin So for each module name "M" in broken unit "u" we have: "M" -> u:M -> ModUnusable reason However in the case of module reexports we were using the *target* module as a key. E.g. if "u:M" is a reexport for "X" from unit "o": "M" -> o:X -> ModUnusable reason Case 1: suppose a reexport without module renaming (u:M -> o:M) from unusable unit u: "M" -> o:M -> ModUnusable reason Here it's claiming that the import of M is unusable because a reexport from u is unusable. But if unit o isn't unusable we could also have in the map: "M" -> o:M -> ModOrigin ... Issue: the Semigroup instance of ModuleOrigin doesn't handle the case (ModUnusable <> ModOrigin) Case 2: similarly we could have 2 unusable units reexporting the same module without renaming, say (u:M -> o:M) and (v:M -> o:M) with u and v unusable. It gives: "M" -> o:M -> ModUnusable ... (for u) "M" -> o:M -> ModUnusable ... (for v) Issue: the Semigroup instance of ModuleOrigin doesn't handle the case (ModUnusable <> ModUnusable). This led to #21097, #16996, #11050. To fix this, in this commit we make ModUnusable track whether the module used as key is a reexport or not (for better error messages) and we use the re-export module as key. E.g. if "u:M" is a reexport for "o:X" and u is unusable, we now record: "M" -> u:M -> ModUnusable reason reexported=True So now, we have two cases for a reexport u:M -> o:X: - u unusable: "M" -> u:M -> ModUnusable ... reexported=True - u usable: "M" -> o:X -> ModOrigin ... reexportedFrom=u:M The second case is indexed with o:X because in this case the Semigroup instance of ModOrigin is used to combine valid expositions of a module (directly or via reexports). Note that module lookup functions select usable modules first (those who have a ModOrigin value), so it doesn't matter if we add new ModUnusable entries in the map like this: "M" -> { u:M -> ModUnusable ... reexported=True o:M -> ModOrigin ... } The ModOrigin one will be used. Only if there is no ModOrigin or ModHidden entry will the ModUnusable error be printed. See T21097 for an example printing several reasons why an import is unusable. - - - - - 3e606230 by Krzysztof Gogolewski at 2023-11-16T09:58:22-05:00 Fix IPE test A helper function was defined in a different module than used. To reproduce: ./hadrian/build test --test-root-dirs=testsuite/tests/rts/ipe - - - - - 49f5264b by Andreas Klebinger at 2023-11-16T20:52:11-05:00 Properly compute unpacked sizes for -funpack-small-strict-fields. Use rep size rather than rep count to compute the size. Fixes #22309 - - - - - b4f84e4b by James Henri Haydon at 2023-11-16T20:52:53-05:00 Explicit methods for Alternative Compose Explicitly define some and many in Alternative instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/181 - - - - - 9bc0dd1f by Ignat Insarov at 2023-11-16T20:53:34-05:00 Add permutations for non-empty lists. Approved by CLC in https://github.com/haskell/core-libraries-committee/issues/68#issuecomment-1221409837 - - - - - 5643ecf9 by Andrew Lelechenko at 2023-11-16T20:53:34-05:00 Update changelog and since annotations for Data.List.NonEmpty.permutations Approved by CLC in https://github.com/haskell/core-libraries-committee/issues/68#issuecomment-1221409837 - - - - - 94ff2134 by Oleg Alexander at 2023-11-16T20:54:15-05:00 Update doc string for traceShow Updated doc string for traceShow. - - - - - faff671a by Luite Stegeman at 2023-11-17T14:12:51+01:00 JS: clean up some foreign imports - - - - - 856e0a4e by Sven Tennie at 2023-11-18T06:54:11-05:00 AArch64: Remove unused instructions As these aren't ever emitted, we don't even know if they work or will ever be used. If one of them is needed in future, we may easily re-add it. Deleted instructions are: - CMN - ANDS - BIC - BICS - EON - ORN - ROR - TST - STP - LDP - DMBSY - - - - - 615441ef by Alan Zimmerman at 2023-11-18T06:54:46-05:00 EPA: Replace Monoid with NoAnn Remove the final Monoid instances in the exact print infrastructure. For Windows CI Metric Decrease: T5205 - - - - - 5a6c49d4 by David Feuer at 2023-11-20T18:53:18-05:00 Speed up stimes in instance Semigroup Endo As discussed at https://github.com/haskell/core-libraries-committee/issues/4 - - - - - cf9da4b3 by Andrew Lelechenko at 2023-11-20T18:53:18-05:00 base: reflect latest changes in the changelog - - - - - 48bf364e by Alan Zimmerman at 2023-11-20T18:53:54-05:00 EPA: Use SrcSpan in EpaSpan This is more natural, since we already need to deal with invalid RealSrcSpans, and that is exactly what SrcSpan.UnhelpfulSpan is for. Updates haddock submodule. - - - - - 97ec37cc by Sebastian Graf at 2023-11-20T18:54:31-05:00 Add regression test for #6070 Fixes #6070. - - - - - e9d5ae41 by Owen Shepherd at 2023-11-21T18:32:23-05:00 chore: Correct typo in the gitlab MR template [skip ci] - - - - - f158a8d0 by Rodrigo Mesquita at 2023-11-21T18:32:59-05:00 Improve error message when reading invalid `.target` files A `.target` file generated by ghc-toolchain or by configure can become invalid if the target representation (`Toolchain.Target`) is changed while the files are not re-generated by calling `./configure` or `ghc-toolchain` again. There is also the issue of hadrian caching the dependencies on `.target` files, which makes parsing fail when reading reading the cached value if the representation has been updated. This patch provides a better error message in both situations, moving away from a terrible `Prelude.read: no parse` error that you would get otherwise. Fixes #24199 - - - - - 955520c6 by Ben Gamari at 2023-11-21T18:33:34-05:00 users guide: Note that QuantifiedConstraints implies ExplicitForAll Fixes #24025. - - - - - 17ec3e97 by Owen Shepherd at 2023-11-22T09:37:28+01:00 fix: Change type signatures in NonEmpty export comments to reflect reality This fixes several typos in the comments of Data.List.NonEmpty export list items. - - - - - 2fd78f9f by Samuel Thibault at 2023-11-22T11:49:13-05:00 Fix the platform string for GNU/Hurd As commited in Cargo https://github.com/haskell/cabal/pull/9434 there is confusion between "gnu" and "hurd". This got fixed in Cargo, we need the converse in Hadrian. Fixes #24180 - - - - - a79960fe by Alan Zimmerman at 2023-11-22T11:49:48-05:00 EPA: Tuple Present no longer has annotation The Present constructor for a Tuple argument will never have an exact print annotation. So make this impossible. - - - - - 121c9ab7 by David Binder at 2023-11-22T21:12:29-05:00 Unify the hpc testsuites The hpc testsuite was split between testsuite/tests/hpc and the submodule libraries/hpc/test. This commit unifies the two testsuites in the GHC repository in the directory testsuite/tests/hpc. - - - - - d2733a05 by Alan Zimmerman at 2023-11-22T21:13:05-05:00 EPA: empty tup_tail has noAnn In Parser.y, the tup_tail rule had the following option | {- empty -} %shift { return [Left noAnn] } Once this works through PostProcess.hs, it means we add an extra Missing constructor if the last item was a comma. Change the annotation type to a Bool to indicate this, and use the EpAnn Anchor for the print location for the others. - - - - - fa576eb8 by Andreas Klebinger at 2023-11-24T08:29:13-05:00 Fix FMA primops generating broken assembly on x86. `genFMA3Code` assumed that we had to take extra precations to avoid overwriting the result of `getNonClobberedReg`. One of these special cases caused a bug resulting in broken assembly. I believe we don't need to hadle these cases specially at all, which means this MR simply deletes the special cases to fix the bug. Fixes #24160 - - - - - 34d86315 by Alan Zimmerman at 2023-11-24T08:29:49-05:00 EPA: Remove parenthesizeHsType This is called from PostProcess.hs, and adds spurious parens. With the looser version of exact printing we had before we could tolerate this, as they would be swallowed by the original at the same place. But with the next change (remove EpAnnNotUsed) they result in duplicates in the output. For Darwin build: Metric Increase: MultiLayerModulesTH_OneShot - - - - - 3ede659d by Vladislav Zavialov at 2023-11-26T06:43:32-05:00 Add name for -Wdeprecated-type-abstractions (#24154) This warning had no name or flag and was triggered unconditionally. Now it is part of -Wcompat. - - - - - 7902ebf8 by Alan Zimmerman at 2023-11-26T06:44:08-05:00 EPA: Remove EpAnnNotUsed We no longer need the EpAnnNotUsed constructor for EpAnn, as we can represent an unused annotation with an anchor having a EpaDelta of zero, and empty comments and annotations. This simplifies code handling annotations considerably. Updates haddock submodule Metric Increase: parsing001 - - - - - 471b2672 by Mario Blažević at 2023-11-26T06:44:48-05:00 Bumped the upper bound of text to <2.2 - - - - - d1bf25c7 by Vladislav Zavialov at 2023-11-26T11:45:49-05:00 Term variable capture (#23740) This patch changes type variable lookup rules (lookupTypeOccRn) and implicit quantification rules (filterInScope) so that variables bound in the term namespace can be captured at the type level {-# LANGUAGE RequiredTypeArguments #-} f1 x = g1 @x -- `x` used in a type application f2 x = g2 (undefined :: x) -- `x` used in a type annotation f3 x = g3 (type x) -- `x` used in an embedded type f4 x = ... where g4 :: x -> x -- `x` used in a type signature g4 = ... This change alone does not allow us to accept examples shown above, but at least it gets them past the renamer. - - - - - da863d15 by Vladislav Zavialov at 2023-11-26T11:46:26-05:00 Update Note [hsScopedTvs and visible foralls] The Note was written before GHC gained support for visible forall in types of terms. Rewrite a few sentences and use a better example. - - - - - b5213542 by Matthew Pickering at 2023-11-27T12:53:59-05:00 testsuite: Add mechanism to collect generic metrics * Generalise the metric logic by adding an additional field which allows you to specify how to query for the actual value. Previously the method of querying the baseline value was abstracted (but always set to the same thing). * This requires rejigging how the stat collection works slightly but now it's more uniform and hopefully simpler. * Introduce some new "generic" helper functions for writing generic stats tests. - collect_size ( deviation, path ) Record the size of the file as a metric - stat_from_file ( metric, deviation, path ) Read a value from the given path, and store that as a metric - collect_generic_stat ( metric, deviation, get_stat) Provide your own `get_stat` function, `lambda way: <Int>`, which can be used to establish the current value of the metric. - collect_generic_stats ( metric_info ): Like collect_generic_stat but provide the whole dictionary of metric definitions. { metric: { deviation: <Int> current: lambda way: <Int> } } * Introduce two new "size" metrics for keeping track of build products. - `size_hello_obj` - The size of `hello.o` from compiling hello.hs - `libdir` - The total size of the `libdir` folder. * Track the number of modules in the AST tests - CountDepsAst - CountDepsParser This lays the infrastructure for #24191 #22256 #17129 - - - - - 7d9a2e44 by ARATA Mizuki at 2023-11-27T12:54:39-05:00 x86: Don't require -mavx2 when using 256-bit floating-point SIMD primitives Fixes #24222 - - - - - 4e5ff6a4 by Alan Zimmerman at 2023-11-27T12:55:15-05:00 EPA: Remove SrcSpanAnn Now that we only have a single constructor for EpAnn, And it uses a SrcSpan for its location, we can do away with SrcSpanAnn completely. It only existed to wrap the original SrcSpan in a location, and provide a place for the exact print annotation. For darwin only: Metric Increase: MultiLayerModulesTH_OneShot Updates haddock submodule - - - - - e05bca39 by Krzysztof Gogolewski at 2023-11-28T08:00:55-05:00 testsuite: don't initialize testdir to '.' The test directory is removed during cleanup, if there's an interrupt that could remove the entire repository. Fixes #24219 - - - - - af881674 by Alan Zimmerman at 2023-11-28T08:01:30-05:00 EPA: Clean up mkScope in Ast.hs Now that we have HasLoc we can get rid of all the custom variants of mkScope For deb10-numa Metric Increase: libdir - - - - - 292983c8 by Ben Gamari at 2023-11-28T22:44:28-05:00 distrib: Rediscover otool and install_name_tool on Darwin In the bindist configure script we must rediscover the `otool` and `install_name_tool`s since they may be different from the build environment. Fixes #24211. - - - - - dfe1c354 by Stefan Schulze Frielinghaus at 2023-11-28T22:45:04-05:00 llvmGen: Align objects in the data section Objects in the data section may be referenced via tagged pointers. Thus, align those objects to a 4- or 8-byte boundary for 32- or 64-bit platforms, respectively. Note, this may need to be reconsidered if objects with a greater natural alignment requirement are emitted as e.g. 128-bit atomics. Fixes #24163. - - - - - f6c486c3 by Matthew Pickering at 2023-11-29T11:08:13-05:00 metrics: Widen libdir and size_hello_obj acceptance window af8816740d9b8759be1a22af8adcb5f13edeb61d shows that the libdir size can fluctuate quite significantly even when the change is quite small. Therefore we widen the acceptance window to 10%. - - - - - 99a6a49c by Alan Zimmerman at 2023-11-29T11:08:49-05:00 EPA: Clean up TC Monad Utils We no longer need the alternative variant of addLocM (addLocMA) nor wrapLocAM, wrapLocSndMA. aarch64-darwin Metric Increase: MultiLayerModulesTH_OneShot deb10-numa-slow Metric Decrease: libdir - - - - - cbc03fa0 by Sebastian Graf at 2023-11-30T12:37:21-05:00 perf tests: Move comments into new `Note [Sensitivity to unique increment]` (#19414) And additionally to T12545, link from T8095, T13386 to this new Note. - - - - - c7623b22 by Alan Zimmerman at 2023-11-30T12:37:56-05:00 EPA: EpaDelta for comment has no comments EpaLocation is used to position things. It has two constructors, EpaSpan holding a SrcSpan, and EpaDelta with a delta position and a possible list of comments. The comment list is needed because the location in EpaDelta has no absolute information to decide which comments should be emitted before them when printing. But it is also used for specifying the position of a comment. To prevent the absurdity of a comment position having a list of comments in it, we make EpaLocation parameterisable, using comments for the normal case and a constant for within comments. Updates haddock submodule. aarch64-darwin Metric Decrease: MultiLayerModulesTH_OneShot - - - - - bd8acc0c by Krzysztof Gogolewski at 2023-11-30T12:38:32-05:00 Kind-check body of a required forall We now require that in 'forall a -> ty', ty has kind TYPE r for some r. Fixes #24176 - - - - - 010fb784 by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - cda9c12d by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 495265b9 by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - d134d1de by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - dfcf629c by Owen Shepherd at 2023-12-03T00:10:10-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - cad3b734 by Owen Shepherd at 2023-12-03T00:10:10-05:00 fix: Add missing property of List.group - - - - - bad37656 by Matthew Pickering at 2023-12-03T00:10:46-05:00 testsuite: Fix T21097b test with make 4.1 (deb9) cee81370cd6ef256f66035e3116878d4cb82e28b recently added a test which failed on deb9 because the version of make was emitting the recipe failure to stdout rather than stderr. One way to fix this is to be more precise in the test about which part of the output we care about inspecting. - - - - - 5efdf421 by Matthew Pickering at 2023-12-03T00:11:21-05:00 testsuite: Track size of libdir in bytes For consistency it's better if we track all size metrics in bytes. Metric Increase: libdir - - - - - f5eb0f29 by Matthew Pickering at 2023-12-03T00:11:22-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - d5610737 by Claudio Bley at 2023-12-06T16:13:33-05:00 Only exit ghci in -e mode when :add command fails Previously, when running `ghci -e ':add Sample.hs'` the process would exit with exit code 1 if the file exists and could be loaded. Fixes #24115 - - - - - 0f0c53a5 by Vladislav Zavialov at 2023-12-06T16:14:09-05:00 T2T in Patterns (#23739) This patch implements the T2T (term-to-type) transformation in patterns. Patterns that are checked against a visible forall can now be written without the `type` keyword: \(type t) (x :: t) -> ... -- old \t (x :: t) -> ... -- new The `t` binder is parsed and renamed as a term pattern (Pat), but then undergoes a conversion to a type pattern (HsTyPat). See the new function pat_to_type_pat in compiler/GHC/Tc/Gen/Pat.hs - - - - - 10a1a6c6 by Sebastian Graf at 2023-12-06T16:14:45-05:00 Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234) Before, the source location would point at the surrounding function definition, causing the confusion in #24234. I also took the opportunity to introduce a new `LazyPatCtx :: HsMatchContext _` to make the warning message say "irrefutable pattern" instead of "pattern binding". - - - - - 36b9a38c by Matthew Pickering at 2023-12-06T16:15:21-05:00 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 - - - - - 91ff0971 by Matthew Pickering at 2023-12-06T16:15:21-05:00 Submodule linter: Allow references to tags We modify the submodule linter so that if the bumped commit is a specific tag then the commit is accepted. Fixes #24241 - - - - - 86f652dc by Zubin Duggal at 2023-12-06T16:15:21-05:00 hadrian: set -Wno-deprecations for directory and Win32 The filepath bump to 1.4.200.1 introduces a deprecation warning. See https://gitlab.haskell.org/ghc/ghc/-/issues/24240 https://github.com/haskell/filepath/pull/206 - - - - - 7ac6006e by Sylvain Henry at 2023-12-06T16:16:02-05:00 Zap OccInfo on case binders during StgCse #14895 #24233 StgCse can revive dead binders: case foo of dead { Foo x y -> Foo x y; ... } ===> case foo of dead { Foo x y -> dead; ... } -- dead is no longer dead So we must zap occurrence information on case binders. Fix #14895 and #24233 - - - - - 57c391c4 by Sebastian Graf at 2023-12-06T16:16:37-05:00 Cpr: Turn an assertion into a check to deal with some dead code (#23862) See the new `Note [Dead code may contain type confusions]`. Fixes #23862. - - - - - c1c8abf8 by Zubin Duggal at 2023-12-08T02:25:07-05:00 testsuite: add test for #23944 - - - - - 6329d308 by Zubin Duggal at 2023-12-08T02:25:07-05:00 driver: Only run a dynamic-too pipeline if object files are going to be generated Otherwise we run into a panic in hscMaybeWriteIface: "Unexpected DT_Dyn state when writing simple interface" when dynamic-too is enabled We could remove the panic and just write the interface even if the state is `DT_Dyn`, but it seems pointless to run the pipeline twice when `hscMaybeWriteIface` is already designed to write both `hi` and `dyn_hi` files if dynamic-too is enabled. Fixes #23944. - - - - - 28811f88 by Simon Peyton Jones at 2023-12-08T05:47:18-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - fec7894f by Simon Peyton Jones at 2023-12-08T05:47:18-05:00 Make SpecConstr deal with casts better This patch does two things, to fix #23209: * It improves SpecConstr so that it no longer quantifies over coercion variables. See Note [SpecConstr and casts] * It improves the rule matcher to deal nicely with the case where the rule does not quantify over coercion variables, but the the template has a cast in it. See Note [Casts in the template] - - - - - 8db8d2fd by Zubin Duggal at 2023-12-08T05:47:54-05:00 driver: Don't lose track of nodes when we fail to resolve cycles The nodes that take part in a cycle should include both hs-boot and hs files, but when we fail to resolve a cycle, we were only counting the nodes from the graph without boot files. Fixes #24196 - - - - - c5b4efd3 by Zubin Duggal at 2023-12-08T05:48:30-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - fae472a9 by Wendao Lee at 2023-12-08T05:49:12-05:00 docs(Data.Char):Add more detailed descriptions for some functions Related changed function's docs: -GHC.Unicode.isAlpha -GHC.Unicode.isPrint -GHC.Unicode.isAlphaNum Add more details for what the function will return. Co-authored-by: Bodigrim <andrew.lelechenko at gmail.com> - - - - - ca7510e4 by Malik Ammar Faisal at 2023-12-08T05:49:55-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - d8baa1bd by Simon Peyton Jones at 2023-12-08T15:40:37+00:00 Take care when simplifying unfoldings This MR fixes a very subtle bug exposed by #24242. See Note [Environment for simplLetUnfolding]. I also updated a bunch of Notes on shadowing - - - - - 03ca551d by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Comments only in FloatIn Relevant to #3458 - - - - - 50c78779 by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Comments only in SpecConstr - - - - - 9431e195 by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Add test for #22238 - - - - - d9e4c597 by Vladislav Zavialov at 2023-12-11T04:19:34-05:00 Make forall a keyword (#23719) Before this change, GHC used to accept `forall` as a term-level identifier: -- from constraints-0.13 forall :: forall p. (forall a. Dict (p a)) -> Dict (Forall p) forall d = ... Now it is a parse error. The -Wforall-identifier warning has served its purpose and is now a deprecated no-op. - - - - - 58d56644 by Zubin Duggal at 2023-12-11T04:20:10-05:00 driver: Ensure we actually clear the interactive context before reloading Previously we called discardIC, but immediately after set the session back to an old HscEnv that still contained the IC Partially addresses #24107 Fixes #23405 - - - - - 8e5745a0 by Zubin Duggal at 2023-12-11T04:20:10-05:00 driver: Ensure we force the lookup of old build artifacts before returning the build plan This prevents us from retaining all previous build artifacts in memory until a recompile finishes, instead only retaining the exact artifacts we need. Fixes #24118 - - - - - 105c370c by Zubin Duggal at 2023-12-11T04:20:10-05:00 testsuite: add test for #24118 and #24107 MultiLayerModulesDefsGhci was not able to catch the leak because it uses :l which discards the previous environment. Using :r catches both of these leaks - - - - - e822ff88 by Zubin Duggal at 2023-12-11T04:20:10-05:00 compiler: Add some strictness annotations to ImportSpec and related constructors This prevents us from retaining entire HscEnvs. Force these ImportSpecs when forcing the GlobalRdrEltX Adds an NFData instance for Bag Fixes #24107 - - - - - 522c12a4 by Zubin Duggal at 2023-12-11T04:20:10-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 188b280d by Arnaud Spiwack at 2023-12-11T15:33:31+01:00 LinearTypes => MonoLocalBinds - - - - - 8e0446df by Arnaud Spiwack at 2023-12-11T15:44:28+01:00 Linear let and where bindings For expediency, the initial implementation of linear types in GHC made it so that let and where binders would always be considered unrestricted. This was rather unpleasant, and probably a big obstacle to adoption. At any rate, this was not how the proposal was designed. This patch fixes this infelicity. It was surprisingly difficult to build, which explains, in part, why it took so long to materialise. As of this patch, let or where bindings marked with %1 will be linear (respectively %p for an arbitrary multiplicity p). Unmarked let will infer their multiplicity. Here is a prototypical example of program that used to be rejected and is accepted with this patch: ```haskell f :: A %1 -> B g :: B %1 -> C h :: A %1 -> C h x = g y where y = f x ``` Exceptions: - Recursive let are unrestricted, as there isn't a clear semantics of what a linear recursive binding would be. - Destructive lets with lazy bindings are unrestricted, as their desugaring isn't linear (see also #23461). - (Strict) destructive lets with inferred polymorphic type are unrestricted. Because the desugaring isn't linear (See #18461 down-thread). Closes #18461 and #18739 Co-authored-by: @jackohughes - - - - - effa7e2d by Matthew Craven at 2023-12-12T04:37:20-05:00 Introduce `dataToTagSmall#` primop (closes #21710) ...and use it to generate slightly better code when dataToTag# is used at a "small data type" where there is no need to mess with "is_too_big_tag" or potentially look at an info table. Metric Decrease: T18304 - - - - - 35c7aef6 by Matthew Craven at 2023-12-12T04:37:20-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 7397c784 by Oleg Grenrus at 2023-12-12T04:37:56-05:00 Allow untyped brackets in typed splices and vice versa. Resolves #24190 Apparently the check was essentially always (as far as I can trace back: d0d47ba76f8f0501cf3c4966bc83966ab38cac27), and while it does catch some mismatches, the type-checker will catch them too. OTOH, it prevents writing completely reasonable programs. - - - - - a3ee3b99 by Moritz Angermann at 2023-12-12T19:50:58-05:00 Drop hard Xcode dependency XCODE_VERSION calls out to `xcodebuild`, which is only available when having `Xcode` installed. The CommandLineTools are not sufficient. To install Xcode, you must have an apple id to download the Xcode.xip from apple. We do not use xcodebuild anywhere in our build explicilty. At best it appears to be a proxy for checking the linker or the compiler. These should rather be done with ``` xcrun ld -version ``` or similar, and not by proxy through Xcode. The CLR should be sufficient for building software on macOS. - - - - - 1c9496e0 by Vladislav Zavialov at 2023-12-12T19:51:34-05:00 docs: update information on RequiredTypeArguments Update the User's Guide and Release Notes to account for the recent progress in the implementation of RequiredTypeArguments. - - - - - d0b17576 by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Fix off-by-one in assertion Previously we failed to account for the NULL terminator `postString` asserted that there is enough room in the buffer for the string. - - - - - a10f9b9b by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. - - - - - 0e0f41c0 by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. - - - - - 64e724c8 by Artin Ghasivand at 2023-12-13T06:34:20-05:00 Remove the "Derived Constraint" argument of TcPluginSolver, docs - - - - - fe6d97dd by Vladislav Zavialov at 2023-12-13T06:34:56-05:00 EPA: Move tokens into GhcPs extension fields (#23447) Summary of changes * Remove Language.Haskell.Syntax.Concrete * Move all tokens into GhcPs extension fields (LHsToken -> EpToken) * Create new TTG extension fields as needed * Drop the MultAnn wrapper Updates the haddock submodule. Co-authored-by: Alan Zimmerman <alan.zimm at gmail.com> - - - - - 8106e695 by Zubin Duggal at 2023-12-13T06:35:34-05:00 testsuite: use copy_files in T23405 This prevents the tree from being dirtied when the file is modified. - - - - - ed0e4099 by Bryan Richter at 2023-12-14T04:30:53-05:00 Document ghc package's PVP-noncompliance This changes nothing, it just makes the status quo explicit. - - - - - 8bef8d9f by Luite Stegeman at 2023-12-14T04:31:33-05:00 JS: Mark spurious CI failures js_fragile(24259) This marks the spurious test failures on the JS platform as js_fragile(24259), so we don't hold up merge requests while fixing the underlying issues. See #24259 - - - - - 1c79526a by Finley McIlwaine at 2023-12-15T12:24:40-08:00 Late plugins - - - - - 000c3302 by Finley McIlwaine at 2023-12-15T12:24:40-08:00 withTiming on LateCCs and late plugins - - - - - be4551ac by Finley McIlwaine at 2023-12-15T12:24:40-08:00 add test for late plugins - - - - - 7c29da9f by Finley McIlwaine at 2023-12-15T12:24:40-08:00 Document late plugins - - - - - 9a52ae46 by Ben Gamari at 2023-12-20T07:07:26-05:00 Fix thunk update ordering Previously we attempted to ensure soundness of concurrent thunk update by synchronizing on the access of the thunk's info table pointer field. This was believed to be sufficient since the indirectee (which may expose a closure allocated by another core) would not be examined until the info table pointer update is complete. However, it turns out that this can result in data races in the presence of multiple threads racing a update a single thunk. For instance, consider this interleaving under the old scheme: Thread A Thread B --------- --------- t=0 Enter t 1 Push update frame 2 Begin evaluation 4 Pause thread 5 t.indirectee=tso 6 Release t.info=BLACKHOLE 7 ... (e.g. GC) 8 Resume thread 9 Finish evaluation 10 Relaxed t.indirectee=x 11 Load t.info 12 Acquire fence 13 Inspect t.indirectee 14 Release t.info=BLACKHOLE Here Thread A enters thunk `t` but is soon paused, resulting in `t` being lazily blackholed at t=6. Then, at t=10 Thread A finishes evaluation and updates `t.indirectee` with a relaxed store. Meanwhile, Thread B enters the blackhole. Under the old scheme this would introduce an acquire-fence but this would only synchronize with Thread A at t=6. Consequently, the result of the evaluation, `x`, is not visible to Thread B, introducing a data race. We fix this by treating the `indirectee` field as we do all other mutable fields. This means we must always access this field with acquire-loads and release-stores. See #23185. - - - - - f4b53538 by Vladislav Zavialov at 2023-12-20T07:08:02-05:00 docs: Fix link to 051-ghc-base-libraries.rst The proposal is no longer available at the previous URL. - - - - - f7e21fab by Matthew Pickering at 2023-12-21T14:57:40+00:00 hadrian: Build all executables in bin/ folder In the end the bindist creation logic copies them all into the bin folder. There is no benefit to building a specific few binaries in the lib/bin folder anymore. This also removes the ad-hoc logic to copy the touchy and unlit executables from stage0 into stage1. It takes <1s to build so we might as well just build it. - - - - - 0038d052 by Zubin Duggal at 2023-12-22T23:28:00-05:00 testsuite: mark jspace as fragile on i386. This test has been flaky for some time and has been failing consistently on i386-linux since 8e0446df landed. See #24261 - - - - - dfd670a0 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 609e6225 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 865513b2 by Ömer Sinan Ağacan at 2023-12-24T10:11:13-05:00 Fix BNF in user manual 6.6.8.2: formal syntax for instance declarations - - - - - c247b6be by Zubin Duggal at 2023-12-25T16:01:23-05:00 docs: document permissibility of -XOverloadedLabels (#24249) Document the permissibility introduced by https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst - - - - - e5b7eb59 by Ömer Sinan Ağacan at 2023-12-25T16:02:03-05:00 Fix a code block syntax in user manual sec. 6.8.8.6 - - - - - 2db11c08 by Ben Gamari at 2023-12-29T15:35:48-05:00 genSym: Reimplement via CAS on 32-bit platforms Previously the remaining use of the C implementation on 32-bit platforms resulted in a subtle bug, #24261. This was due to the C object (which used the RTS's `atomic_inc64` macro) being compiled without `-threaded` yet later being used in a threaded compiler. Side-step this issue by using the pure Haskell `genSym` implementation on all platforms. This required implementing `fetchAddWord64Addr#` in terms of CAS on 64-bit platforms. - - - - - 19328a8c by Xiaoyan Ren at 2023-12-29T15:36:30-05:00 Do not color the diagnostic code in error messages (#24172) - - - - - 685b467c by Krzysztof Gogolewski at 2023-12-29T15:37:06-05:00 Enforce that bindings of implicit parameters are lifted Fixes #24298 - - - - - bc4d67b7 by Matthew Craven at 2023-12-31T06:15:42-05:00 StgToCmm: Detect some no-op case-continuations ...and generate no code for them. Fixes #24264. - - - - - 5b603139 by Krzysztof Gogolewski at 2023-12-31T06:16:18-05:00 Revert "testsuite: mark jspace as fragile on i386." This reverts commit 0038d052c8c80b4b430bb2aa1c66d5280be1aa95. The atomicity bug should be fixed by !11802. - - - - - d55216ad by Krzysztof Gogolewski at 2024-01-01T12:05:49-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 8b340bc7 by Ömer Sinan Ağacan at 2024-01-01T12:06:29-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - ac20b669 by John Ericson at 2024-01-02T12:11:34-05:00 Generate LLVM min/max bound policy via Hadrian Per #23966, I want the top-level configure to only generate configuration data for Hadrian, not do any "real" tasks on its own. This is part of that effort --- one less file generated by it. (It is still done with a `.in` file, so in a future world non-Hadrian also can easily create this file.) Split modules: - GHC.CmmToLlvm.Config - GHC.CmmToLlvm.Version - GHC.CmmToLlvm.Version.Bounds - GHC.CmmToLlvm.Version.Type This also means we can get rid of the silly `unused.h` introduced in !6803 / 7dfcab2f4bcb7206174ea48857df1883d05e97a2 as temporary kludge. Part of #23966 - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/merge_request_templates/Default.md - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/Lexer.x - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/CmmToLlvm/Config.hs - compiler/GHC/CmmToLlvm/Data.hs - + compiler/GHC/CmmToLlvm/Version.hs - + compiler/GHC/CmmToLlvm/Version/Bounds.hs.in - + compiler/GHC/CmmToLlvm/Version/Type.hs - compiler/GHC/Core.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/LateCC.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/44d40a4fc28a66008d9dbe3bd8100e00294bd09b...ac20b6697b35bc3ee082db8d46cb1a84a6a450c7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/44d40a4fc28a66008d9dbe3bd8100e00294bd09b...ac20b6697b35bc3ee082db8d46cb1a84a6a450c7 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Tue Jan 2 18:18:59 2024 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Tue, 02 Jan 2024 13:18:59 -0500 Subject: [Git][ghc/ghc][wip/hc2-test] fix Message-ID: <659453933e844_1a27687641cdc1174c3@gitlab.mail> Matthew Pickering pushed to branch wip/hc2-test at Glasgow Haskell Compiler / GHC Commits: ba1e01b9 by GHC GitLab CI at 2024-01-02T18:18:49+00:00 fix - - - - - 1 changed file: - hadrian/src/Rules/Test.hs Changes: ===================================== hadrian/src/Rules/Test.hs ===================================== @@ -353,6 +353,8 @@ needTestsuitePackages stg = do -- Also need wrappers to test a normal cross compiler because the libraries are built with the same compiler we are testing -- (much in the same way as testing a stage1 compiler) when (stg == Stage1 && cross) $ do + libpkgs <- map (Stage2,) . filter isLibrary <$> allpkgs Stage2 + need =<< mapM (uncurry pkgFile) libpkgs -- Windows not supported as the wrapper scripts don't work on windows.. we could -- support it with a separate .bat or C wrapper code path but seems overkill when no-one will -- probably ever try and do this. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba1e01b92c42c6c6952d3b3b52f6733a72846e33 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba1e01b92c42c6c6952d3b3b52f6733a72846e33 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 07:54:57 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 03 Jan 2024 02:54:57 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/9.6.4-backports-2 Message-ID: <659512d1ca259_146b14338380319d8@gitlab.mail> Zubin pushed new branch wip/9.6.4-backports-2 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/9.6.4-backports-2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 10:31:57 2024 From: gitlab at gitlab.haskell.org (Teo Camarasu (@teo)) Date: Wed, 03 Jan 2024 05:31:57 -0500 Subject: [Git][ghc/ghc][wip/nonmoving-census] 347 commits: Profiling: Properly escape characters when using `-pj`. Message-ID: <6595379de3b9_146b14414d2246121b@gitlab.mail> Teo Camarasu pushed to branch wip/nonmoving-census at Glasgow Haskell Compiler / GHC Commits: e5c00092 by Andreas Klebinger at 2023-09-14T08:57:43-04:00 Profiling: Properly escape characters when using `-pj`. There are some ways in which unusual characters like quotes or others can make it into cost centre names. So properly escape these. Fixes #23924 - - - - - ec490578 by Ellie Hermaszewska at 2023-09-14T08:58:24-04:00 Use clearer example variable names for bool eliminator - - - - - 5126a2fe by Sylvain Henry at 2023-09-15T11:18:02-04:00 Add missing int64/word64-to-double/float rules (#23907) CLC proposal: https://github.com/haskell/core-libraries-committee/issues/203 - - - - - 566ef411 by Mario Blažević at 2023-09-15T11:18:43-04:00 Fix and test TH pretty-printing of type operator role declarations This commit fixes and tests `Language.Haskell.TH.Ppr.pprint` so that it correctly pretty-prints `type role` declarations for operator names. Fixes #23954 - - - - - 8e05c54a by Simon Peyton Jones at 2023-09-16T01:42:33-04:00 Use correct FunTyFlag in adjustJoinPointType As the Lint error in #23952 showed, the function adjustJoinPointType was failing to adjust the FunTyFlag when adjusting the type. I don't think this caused the seg-fault reported in the ticket, but it is definitely. This patch fixes it. It is tricky to come up a small test case; Krzysztof came up with this one, but it only triggers a failure in GHC 9.6. - - - - - 778c84b6 by Pierre Le Marre at 2023-09-16T01:43:15-04:00 Update to Unicode 15.1.0 See: https://www.unicode.org/versions/Unicode15.1.0/ - - - - - f9d79a6c by Alan Zimmerman at 2023-09-18T00:00:14-04:00 EPA: track unicode version for unrestrictedFunTyCon Closes #23885 Updates haddock submodule - - - - - 9374f116 by Andrew Lelechenko at 2023-09-18T00:00:54-04:00 Bump parsec submodule to allow text-2.1 and bytestring-0.12 - - - - - 7ca0240e by Ben Gamari at 2023-09-18T15:16:48-04:00 base: Advertise linear time of readFloat As noted in #23538, `readFloat` has runtime that scales nonlinearly in the size of its input. Consequently, its use on untrusted input can be exploited as a denial-of-service vector. Point this out and suggest use of `read` instead. See #23538. - - - - - f3f58f13 by Simon Peyton Jones at 2023-09-18T15:17:24-04:00 Remove dead code GHC.CoreToStg.Prep.canFloat This function never fires, so we can delete it: #23965. - - - - - ccab5b15 by Ben Gamari at 2023-09-18T15:18:02-04:00 base/changelog: Move fix for #23907 to 9.8.1 section Since the fix was backported to 9.8.1 - - - - - 51b57d65 by Matthew Pickering at 2023-09-19T08:44:31-04:00 Add aarch64 alpine bindist This is dynamically linked and makes creating statically linked executables more straightforward. Fixes #23482 - - - - - 02c87213 by Matthew Pickering at 2023-09-19T08:44:31-04:00 Add aarch64-deb11 bindist This adds a debian 11 release job for aarch64. Fixes #22005 - - - - - 8b61dfd6 by Alexis King at 2023-09-19T08:45:13-04:00 Don’t store the async exception masking state in CATCH frames - - - - - 86d2971e by doyougnu at 2023-09-19T19:08:19-04:00 compiler,ghci: error codes link to HF error index closes: #23259 - adds -fprint-error-index-links={auto|always|never} flag - - - - - 5f826c18 by sheaf at 2023-09-19T19:09:03-04:00 Pass quantified tyvars in tcDefaultAssocDecl This commit passes the correct set of quantified type variables written by the user in associated type default declarations for validity checking. This ensures that validity checking of associated type defaults mirrors that of standalone type family instances. Fixes #23768 (see testcase T23734 in subsequent commit) - - - - - aba18424 by sheaf at 2023-09-19T19:09:03-04:00 Avoid panic in mkGADTVars This commit avoids panicking in mkGADTVars when we encounter a type variable as in #23784 that is bound by a user-written forall but not actually used. Fixes #23784 - - - - - a525a92a by sheaf at 2023-09-19T19:09:03-04:00 Adjust reporting of unused tyvars in data FamInsts This commit adjusts the validity checking of data family instances to improve the reporting of unused type variables. See Note [Out of scope tvs in data family instances] in GHC.Tc.Validity. The problem was that, in a situation such as data family D :: Type data instance forall (d :: Type). D = MkD the RHS passed to 'checkFamPatBinders' would be the TyCon app R:D d which mentions the type variable 'd' quantified in the user-written forall. Thus, when computing the set of unused type variables in the RHS of the data family instance, we would find that 'd' is used, and report a strange error message that would say that 'd' is not bound on the LHS. To fix this, we special-case the data-family instance case, manually extracting all the type variables that appear in the arguments of all the data constructores of the data family instance. Fixes #23778 - - - - - 28dd52ee by sheaf at 2023-09-19T19:09:03-04:00 Unused tyvars in FamInst: only report user tyvars This commit changes how we perform some validity checking for coercion axioms to mirror how we handle default declarations for associated type families. This allows us to keep track of whether type variables in type and data family instances were user-written or not, in order to only report the user-written ones in "unused type variable" error messages. Consider for example: {-# LANGUAGE PolyKinds #-} type family F type instance forall a. F = () In this case, we get two quantified type variables, (k :: Type) and (a :: k); the second being user-written, but the first is introduced by the typechecker. We should only report 'a' as being unused, as the user has no idea what 'k' is. Fixes #23734 - - - - - 1eed645c by sheaf at 2023-09-19T19:09:03-04:00 Validity: refactor treatment of data families This commit refactors the reporting of unused type variables in type and data family instances to be more principled. This avoids ad-hoc logic in the treatment of data family instances. - - - - - 35bc506b by John Ericson at 2023-09-19T19:09:40-04:00 Remove `ghc-cabal` It is dead code since the Make build system was removed. I tried to go over every match of `git grep -i ghc-cabal` to find other stray bits. Some of those might be workarounds that can be further removed. - - - - - 665ca116 by John Paul Adrian Glaubitz at 2023-09-19T19:10:39-04:00 Re-add unregisterised build support for sparc and sparc64 Closes #23959 - - - - - 142f8740 by Matthew Pickering at 2023-09-19T19:11:16-04:00 Bump ci-images to use updated version of Alex Fixes #23977 - - - - - fa977034 by John Ericson at 2023-09-21T12:55:25-04:00 Use Cabal 3.10 for Hadrian We need the newer version for `CABAL_FLAG_*` env vars for #17191. - - - - - a5d22cab by John Ericson at 2023-09-21T12:55:25-04:00 hadrian: `need` any `configure` script we will call When the script is changed, we should reconfigure. - - - - - db882b57 by John Ericson at 2023-09-21T12:55:25-04:00 hadrian: Make it easier to debug Cabal configure Right now, output is squashed. This make per-package configure scripts extremely hard to maintain, because we get vague "library is missing" errors when the actually probably is usually completely unrelated except for also involving the C/C++ toolchain. (I can always pass `-VVV` to Hadrian locally, but these errors are subtle and I often cannot reproduce them locally!) `--disable-option-checking` was added back in 75c6e0684dda585c37b4ac254cd7a13537a59a91 but seems to be a bit overkill; if other flags are passed that are not recognized behind the two from Cabal mentioned in the former comment, we *do* want to know about it. - - - - - 7ed65f5a by John Ericson at 2023-09-21T12:55:25-04:00 hadrian: Increase verbosity of certain cabal commands This is a hack to get around the cabal function we're calling *decreasing* the verbosity it passes to another function, which is the stuff we often actually care about. Sigh. Keeping this a separate commit so if this makes things too verbose it is easy to revert. - - - - - a4fde569 by John Ericson at 2023-09-21T12:55:25-04:00 rts: Move most external symbols logic to the configure script This is much more terse because we are programmatically handling the leading underscore. `findPtr` however is still handled in the Cabal file because we need a newer Cabal to pass flags to the configure script automatically. Co-Authored-By: Ben Gamari <ben at well-typed.com> - - - - - 56cc85fb by Andrew Lelechenko at 2023-09-21T12:56:21-04:00 Bump Cabal submodule to allow text-2.1 and bytestring-0.12 - - - - - 0cd6148c by Matthew Pickering at 2023-09-21T12:56:21-04:00 hadrian: Generate Distribution/Fields/Lexer.x before creating a source-dist - - - - - b10ba6a3 by Andrew Lelechenko at 2023-09-21T12:56:21-04:00 Bump hadrian's index-state to upgrade alex at least to 3.2.7.3 - - - - - 11ecc37b by Luite Stegeman at 2023-09-21T12:57:03-04:00 JS: correct file size and times Programs produced by the JavaScript backend were returning incorrect file sizes and modification times, causing cabal related tests to fail. This fixes the problem and adds an additional test that verifies basic file information operations. fixes #23980 - - - - - b35fd2cd by Ben Gamari at 2023-09-21T12:57:39-04:00 gitlab-ci: Drop libiserv from upload_ghc_libs libiserv has been merged into the ghci package. - - - - - 37ad04e8 by Ben Gamari at 2023-09-21T12:58:15-04:00 testsuite: Fix Windows line endings - - - - - 5795b365 by Ben Gamari at 2023-09-21T12:58:15-04:00 testsuite: Use makefile_test - - - - - 15118740 by Ben Gamari at 2023-09-21T12:58:55-04:00 system-cxx-std-lib: Add license and description - - - - - 0208f1d5 by Ben Gamari at 2023-09-21T12:59:33-04:00 gitlab/issue-templates: Rename bug.md -> default.md So that it is visible by default. - - - - - 23cc3f21 by Andrew Lelechenko at 2023-09-21T20:18:11+01:00 Bump submodule text to 2.1 - - - - - b8e4fe23 by Andrew Lelechenko at 2023-09-22T20:05:05-04:00 Bump submodule unix to 2.8.2.1 - - - - - 54b2016e by John Ericson at 2023-09-23T11:40:41-04:00 Move lib{numa,dw} defines to RTS configure Clean up the m4 to handle the auto case always and be more consistent. Also simplify the CPP --- we should always have both headers if we are using libnuma. "side effects" (AC_DEFINE, and AC_SUBST) are removed from the macros to better separate searching from actions taken based on search results. This might seem overkill now, but will make shuffling logic between configure scripts easier later. The macro comments are converted from `dnl` to `#` following the recomendation in https://www.gnu.org/software/autoconf/manual/autoconf-2.71/html_node/Macro-Definitions.html - - - - - d51b601b by John Ericson at 2023-09-23T11:40:50-04:00 Shuffle libzstd configuring between scripts Like the prior commit for libdw and libnuma, `AC_DEFINE` to RTS configure, `AC_SUBST` goes to the top-level configure script, and the documentation of the m4 macro is improved. - - - - - d1425af0 by John Ericson at 2023-09-23T11:41:03-04:00 Move `FP_ARM_OUTLINE_ATOMICS` to RTS configure It is just `AC_DEFINE` it belongs there instead. - - - - - 18de37e4 by John Ericson at 2023-09-23T11:41:03-04:00 Move mmap in the runtime linker check to the RTS configure `AC_DEFINE` should go there instead. - - - - - 74132c2b by Andrew Lelechenko at 2023-09-25T21:56:54-04:00 Elaborate comment on GHC_NO_UNICODE - - - - - de142aa2 by Ben Gamari at 2023-09-26T15:25:03-04:00 gitlab-ci: Mark T22012 as broken on CentOS 7 Due to #23979. - - - - - 6a896ce8 by Teo Camarasu at 2023-09-26T15:25:39-04:00 hadrian: better error for failing to find file's dependencies Resolves #24004 - - - - - d697a6c2 by Stefan Holdermans at 2023-09-26T20:58:37+00:00 Refactor uses of `partitionEithers . map` This patch changes occurences of the idiom `partitionEithers (map f xs)` by the simpler form `partitionWith f xs` where `partitionWith` is the utility function defined in `GHC.Utils.Misc`. Resolves: #23953 - - - - - 8a2968b7 by Stefan Holdermans at 2023-09-26T20:58:37+00:00 Refactor uses of `partitionEithers <$> mapM f xs` This patch changes occurences of the idiom `partitionEithers <$> mapM f xs` by the simpler form `partitionWithM f xs` where `partitionWithM` is a utility function newly added to `GHC.Utils.Misc`. - - - - - 6a27eb97 by Stefan Holdermans at 2023-09-26T20:58:37+00:00 Mark `GHC.Utils.Misc.partitionWithM` as inlineable This patch adds an `INLINEABLE` pragma for `partitionWithM` to ensure that the right-hand side of the definition of this function remains available for specialisation at call sites. - - - - - f1e5245a by David Binder at 2023-09-27T01:19:00-04:00 Add RTS option to supress tix file - - - - - 1f43124f by David Binder at 2023-09-27T01:19:00-04:00 Add expected output to testsuite in test interface-stability/base-exports - - - - - b9d2c354 by David Binder at 2023-09-27T01:19:00-04:00 Expose HpcFlags and getHpcFlags from GHC.RTS.Flags - - - - - 345675c6 by David Binder at 2023-09-27T01:19:00-04:00 Fix expected output of interface-stability test - - - - - 146e1c39 by David Binder at 2023-09-27T01:19:00-04:00 Implement getHpcFlags - - - - - 61ba8e20 by David Binder at 2023-09-27T01:19:00-04:00 Add section in user guide - - - - - ea05f890 by David Binder at 2023-09-27T01:19:01-04:00 Rename --emit-tix-file to --write-tix-file - - - - - cabce2ce by David Binder at 2023-09-27T01:19:01-04:00 Update the golden files for interface stability - - - - - 1dbdb9d0 by Krzysztof Gogolewski at 2023-09-27T01:19:37-04:00 Refactor: introduce stgArgRep The function 'stgArgType' returns the type in STG. But this violates the abstraction: in STG we're supposed to operate on PrimReps. This introduces stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep1 ty = typePrimRep1 (stgArgType ty) stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) stgArgType is still directly used for unboxed tuples (should be fixable), FFI and in ticky. - - - - - b02f8042 by Mario Blažević at 2023-09-27T17:33:28-04:00 Fix TH pretty-printer's parenthesization This PR Fixes `Language.Haskell.TH.Ppr.pprint` so it correctly emits parentheses where needed. Fixes #23962, #23968, #23971, and #23986 - - - - - 79104334 by Krzysztof Gogolewski at 2023-09-27T17:34:04-04:00 Add a testcase for #17564 The code in the ticket relied on the behaviour of Derived constraints. Derived constraints were removed in GHC 9.4 and now the code works as expected. - - - - - d7a80143 by sheaf at 2023-09-28T03:25:53-04:00 lint-codes: add new modes of operation This commit adds two new modes of operation to the lint-codes utility: list - list all statically used diagnostic codes outdated - list all outdated diagnostic codes The previous behaviour is now: test - test consistency and coverage of diagnostic codes - - - - - 477d223c by sheaf at 2023-09-28T03:25:53-04:00 lint codes: avoid using git-grep We manually traverse through the filesystem to find the diagnostic codes embedded in .stdout and .stderr files, to avoid any issues with old versions of grep. Fixes #23843 - - - - - a38ae69a by sheaf at 2023-09-28T03:25:53-04:00 lint-codes: add Hadrian targets This commit adds new Hadrian targets: codes, codes:used - list all used diagnostic codes codes:outdated - list outdated diagnostic codes This allows users to easily query GHC for used and outdated diagnostic codes, e.g. hadrian/build -j --flavour=<..> codes will list all used diagnostic codes in the command line by running the lint-codes utility in the "list codes" mode of operation. The diagnostic code consistency and coverage test is still run as usual, through the testsuite: hadrian/build test --only="codes" - - - - - 9cdd629b by Ben Gamari at 2023-09-28T03:26:29-04:00 hadrian: Install LICENSE files in bindists Fixes #23548. - - - - - b8ebf876 by Matthew Craven at 2023-09-28T03:27:05-04:00 Fix visibility when eta-reducing a type lambda Fixes #24014. - - - - - d3874407 by Torsten Schmits at 2023-09-30T16:08:10-04:00 Fix several mistakes around free variables in iface breakpoints Fixes #23612 , #23607, #23998 and #23666. MR: !11026 The fingerprinting logic in `Iface.Recomp` failed lookups when processing decls containing breakpoints for two reasons: * IfaceBreakpoint created binders for free variables instead of expressions * When collecting free names for the dependency analysis for fingerprinting, breakpoint FVs were skipped - - - - - ef5342cd by Simon Peyton Jones at 2023-09-30T16:08:48-04:00 Refactor to combine HsLam and HsLamCase This MR is pure refactoring (#23916): * Combine `HsLam` and `HsLamCase` * Combine `HsCmdLam` and `HsCmdLamCase` This just arranges to treat uniformly \x -> e \case pi -> ei \cases pis -> ie In the exising code base the first is treated differently to the latter two. No change in behaviour. More specifics: * Combine `HsLam` and `HsLamCase` (constructors of `Language.Haskell.Syntax.Expr.HsExpr`) into one data construtor covering * Lambda * `\case` * `\cases` * The new `HsLam` has an argument of type `HsLamVariant` to distinguish the three cases. * Similarly, combine `HsCmdLam` and `HsCmdLamCase` (constructors of `Language.Haskell.Syntax.Expr.HsCmd` ) into one. * Similarly, combine `mkHsLamPV` and `mkHsLamCasePV` (methods of class `DisambECP`) into one. (Thank you Alan Zimmerman.) * Similarly, combine `LambdaExpr` and `LamCaseAlt` (constructors of `Language.Haskell.Syntax.Expr.HsMatchContext`) into one: `LamAlt` with a `HsLamVariant` argument. * Similarly, combine `KappaExpr` and `ArrowLamCaseAlt` (constructors of `Language.Haskell.Syntax.Expr.HsArrowMatchContext`) into one: `ArrowLamAlt` with a `HsLamVariant` argument. * Similarly, combine `PsErrLambdaInPat` and `PsErrLambdaCaseInPat` (constructors of `GHC.Parser.Errors.Ppr.PsError`) into one. * Similarly, combine `PsErrLambdaInPat` and `PsErrLambdaCaseInPat` (constructors of `GHC.Parser.Errors.Ppr.PsError`) into one. * In the same `PsError` data type, combine `PsErrLambdaCmdInFunAppCmd` and `PsErrLambdaCaseCmdInFunAppCmd` into one. * In the same `PsError` data tpye, combine `PsErrLambdaInFunAppExpr` and `PsErrLambdaCaseInFunAppExpr` into one. p* Smilarly combine `ExpectedFunTyLam` and `ExpectedFunTyLamCase` (constructors of `GHC.Tc.Types.Origin.ExpectedFunTyOrigin`) into one. Phew! - - - - - b048bea0 by Andreas Klebinger at 2023-09-30T16:09:24-04:00 Arm: Make ppr methods easier to use by not requiring NCGConfig - - - - - 2adc0508 by Andreas Klebinger at 2023-09-30T16:09:24-04:00 AArch64: Fix broken conditional jumps for offsets >= 1MB Rewrite conditional jump instructions with offsets >= 1MB to use unconditional jumps to avoid overflowing the immediate. Fixes #23746 - - - - - 1424f790 by Alan Zimmerman at 2023-09-30T16:10:00-04:00 EPA: Replace Monoid with NoAnn We currently use the Monoid class as a constraint on Exact Print Annotation functions, so we can use mempty. But this leads to requiring Semigroup instances too, which do not always make sense. Instead, introduce a class NoAnn, with a function noAnn analogous to mempty. Closes #20372 Updates haddock submodule - - - - - c1a3ecde by Ben Gamari at 2023-09-30T16:10:36-04:00 users-guide: Refactor handling of :base-ref: et al. - - - - - bc204783 by Richard Eisenberg at 2023-10-02T14:50:52+02:00 Simplify and correct nasty case in coercion opt This fixes #21062. No test case, because triggering this code seems challenging. - - - - - 9c9ca67e by Andrew Lelechenko at 2023-10-04T05:42:28-04:00 Bump bytestring submodule to 0.12.0.2 - - - - - 4e46dc2b by Andrew Lelechenko at 2023-10-04T05:42:28-04:00 Inline bucket_match - - - - - f6b2751f by Ben Gamari at 2023-10-04T05:43:05-04:00 configure: Fix #21712 again This is a bit of a shot in the dark to fix #24033, which appears to be another instance of #21712. For some reason the ld-override logic *still* appears to be active on Darwin targets (or at least one). Consequently, on misconfigured systems we may choose a non-`ld64` linker. It's a bit unclear exactly what happened in #24033 but ultimately the check added for #21712 was not quite right, checking for the `ghc_host_os` (the value of which depends upon the bootstrap compiler) instead of the target platform. Fix this. Fixes #24033. - - - - - 2f0a101d by Krzysztof Gogolewski at 2023-10-04T05:43:42-04:00 Add a regression test for #24029 - - - - - 8cee3fd7 by sheaf at 2023-10-04T05:44:22-04:00 Fix non-symbolic children lookup of fixity decl The fix for #23664 did not correctly account for non-symbolic names when looking up children of a given parent. This one-line fix changes that. Fixes #24037 - - - - - a4785b33 by Cheng Shao at 2023-10-04T05:44:59-04:00 rts: fix incorrect ticket reference - - - - - e037f459 by Ben Gamari at 2023-10-04T05:45:35-04:00 users-guide: Fix discussion of -Wpartial-fields * fix a few typos * add a new example showing when the warning fires * clarify the existing example * point out -Wincomplete-record-selects Fixes #24049. - - - - - 8ff3134e by Matthew Pickering at 2023-10-05T05:34:58-04:00 Revert "Pass preprocessor options to C compiler when building foreign C files (#16737)" This reverts commit 1c18d3b41f897f34a93669edaebe6069f319f9e2. `-optP` should pass options to the preprocessor, that might be a very different program to the C compiler, so passing the options to the C compiler is likely to result in `-optP` being useless. Fixes #17185 and #21291 - - - - - 8f6010b9 by Ben Gamari at 2023-10-05T05:35:36-04:00 rts/nonmoving: Fix on LLP64 platforms Previously `NONMOVING_SEGMENT_MASK` and friends were defined with the `UL` size suffix. However, this is wrong on LLP64 platforms like Windows, where `long` is 32-bits. Fixes #23003. Fixes #24042. - - - - - f20d02f8 by Andreas Klebinger at 2023-10-05T05:36:14-04:00 Fix isAArch64Bitmask for 32bit immediates. Fixes #23802 - - - - - 63afb701 by Bryan Richter at 2023-10-05T05:36:49-04:00 Work around perf note fetch failure Addresses #24055. - - - - - 242102f4 by Krzysztof Gogolewski at 2023-10-05T05:37:26-04:00 Add a test for #21348 - - - - - 7d390bce by Rewbert at 2023-10-05T05:38:08-04:00 Fixes #24046 - - - - - 69abb171 by Finley McIlwaine at 2023-10-06T14:06:28-07:00 Ensure unconstrained instance dictionaries get IPE info In the `StgRhsCon` case of `GHC.Stg.Debug.collectStgRhs`, we were not coming up with an initial source span based on the span of the binder, which was causing instance dictionaries without dynamic superclass constraints to not have source locations in their IPE info. Now they do. Resolves #24005 - - - - - 390443b7 by Andreas Klebinger at 2023-10-07T10:00:20-04:00 rts: Split up rts/include/stg/MachRegs.h by arch - - - - - 3685942f by Bryan Richter at 2023-10-07T10:00:56-04:00 Actually set hackage index state Or at least, use a version of the cabal command that *claims* to set the index state. Time will tell. - - - - - 46a0e5be by Bryan Richter at 2023-10-07T10:00:56-04:00 Update hackage index state - - - - - d4b037de by Bryan Richter at 2023-10-07T10:00:56-04:00 Ensure hadrian uses CI's hackage index state - - - - - e206be64 by Andrew Lelechenko at 2023-10-08T15:06:14-04:00 Do not use O_NONBLOCK on regular files or block devices CLC proposal https://github.com/haskell/core-libraries-committee/issues/166 - - - - - a06197c4 by David Binder at 2023-10-08T15:06:55-04:00 Update hpc-bin submodule to 0.69 - - - - - ed6785b6 by David Binder at 2023-10-08T15:06:55-04:00 Update Hadrian with correct path to happy file for hpc-bin - - - - - 94066d58 by Alan Zimmerman at 2023-10-09T21:35:53-04:00 EPA: Introduce HasAnnotation class The class is defined as class HasAnnotation e where noAnnSrcSpan :: SrcSpan -> e This generalises noAnnSrcSpan, and allows noLocA :: (HasAnnotation e) => a -> GenLocated e a noLocA = L (noAnnSrcSpan noSrcSpan) - - - - - 8792a1bc by Ben Gamari at 2023-10-09T21:36:29-04:00 Bump unix submodule to v2.8.3.0 - - - - - e96c51cb by Andreas Klebinger at 2023-10-10T16:44:27+01:00 Add a flag -fkeep-auto-rules to optionally keep auto-generated rules around. The motivation for the flag is given in #21917. - - - - - 3ed58cef by Matthew Pickering at 2023-10-10T19:01:22-04:00 hadrian: Add ghcToolchain to tool args list This allows you to load ghc-toolchain and ghc-toolchain-bin into HLS. - - - - - 476c02d4 by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Normalise triple via config.sub We were not normalising the target triple anymore like we did with the old make build system. Fixes #23856 - - - - - 303dd237 by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Add missing vendor normalisation This is copied from m4/ghc_convert_vendor.m4 Towards #23868 - - - - - 838026c9 by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Add loongarch64 to parseArch Towards #23868 - - - - - 1a5bc0b5 by Matthew Pickering at 2023-10-10T19:01:22-04:00 Add same LD hack to ghc-toolchain In the ./configure script, if you pass the `LD` variable then this has the effect of stopping use searching for a linker and hence passing `-fuse-ld=...`. We want to emulate this logic in ghc-toolchain, if a use explicilty specifies `LD` variable then don't add `-fuse-ld=..` with the goal of making ./configure and ghc-toolchain agree on which flags to use when using the C compiler as a linker. This is quite unsavoury as we don't bake the choice of LD into the configuration anywhere but what's important for now is making ghc-toolchain and ./configure agree as much as possible. See #23857 for more discussion - - - - - 42d50b5a by Ben Gamari at 2023-10-10T19:01:22-04:00 ghc-toolchain: Check for C99 support with -std=c99 Previously we failed to try enabling C99 support with `-std=c99`, as `autoconf` attempts. This broke on older compilers (e.g. CentOS 7) which don't enable C99 by default. Fixes #23879. - - - - - da2961af by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Add endianess check using __BYTE_ORDER__ macro In very old toolchains the BYTE_ORDER macro is not set but thankfully the __BYTE_ORDER__ macro can be used instead. - - - - - d8da73cd by Matthew Pickering at 2023-10-10T19:01:22-04:00 configure: AC_PATH_TARGET_TOOL for LD We want to make sure that LD is set to an absolute path in order to be consistent with the `LD=$(command -v ld)` call. The AC_PATH_TARGET_TOOL macro uses the absolute path rather than AC_CHECK_TARGET_TOOL which might use a relative path. - - - - - 171f93cc by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Check whether we need -std=gnu99 for CPP as well In ./configure the C99 flag is passed to the C compiler when used as a C preprocessor. So we also check the same thing in ghc-toolchain. - - - - - 89a0918d by Matthew Pickering at 2023-10-10T19:01:22-04:00 Check for --target linker flag separately to C compiler There are situations where the C compiler doesn't accept `--target` but when used as a linker it does (but doesn't do anything most likely) In particular with old gcc toolchains, the C compiler doesn't support --target but when used as a linker it does. - - - - - 37218329 by Matthew Pickering at 2023-10-10T19:01:22-04:00 Use Cc to compile test file in nopie check We were attempting to use the C compiler, as a linker, to compile a file in the nopie check, but that won't work in general as the flags we pass to the linker might not be compatible with the ones we pass when using the C compiler. - - - - - 9b2dfd21 by Matthew Pickering at 2023-10-10T19:01:22-04:00 configure: Error when ghc-toolchain fails to compile This is a small QOL change as if you are working on ghc-toolchain and it fails to compile then configure will continue and can give you outdated results. - - - - - 1f0de49a by Matthew Pickering at 2023-10-10T19:01:22-04:00 configure: Check whether -no-pie works when the C compiler is used as a linker `-no-pie` is a flag we pass when using the C compiler as a linker (see pieCCLDOpts in GHC.Driver.Session) so we should test whether the C compiler used as a linker supports the flag, rather than just the C compiler. - - - - - 62cd2579 by Matthew Pickering at 2023-10-10T19:01:22-04:00 ghc-toolchain: Remove javascript special case for --target detection emcc when used as a linker seems to ignore the --target flag, and for consistency with configure which now tests for --target, we remove this special case. - - - - - 0720fde7 by Ben Gamari at 2023-10-10T19:01:22-04:00 toolchain: Don't pass --target to emscripten toolchain As noted in `Note [Don't pass --target to emscripten toolchain]`, emscripten's `emcc` is rather inconsistent with respect to its treatment of the `--target` flag. Avoid this by special-casing this toolchain in the `configure` script and `ghc-toolchain`. Fixes on aspect of #23744. - - - - - 6354e1da by Matthew Pickering at 2023-10-10T19:01:22-04:00 hadrian: Don't pass `--gcc-options` as a --configure-arg to cabal configure Stop passing -gcc-options which mixed together linker flags and non-linker flags. There's no guarantee the C compiler will accept both of these in each mode. - - - - - c00a4bd6 by Ben Gamari at 2023-10-10T19:01:22-04:00 configure: Probe stage0 link flags For consistency with later stages and CC. - - - - - 1f11e7c4 by Sebastian Graf at 2023-10-10T19:01:58-04:00 Stricter Binary.get in GHC.Types.Unit (#23964) I noticed some thunking while looking at Core. This change has very modest, but throughout positive ghc/alloc effect: ``` hard_hole_fits(normal) ghc/alloc 283,057,664 281,620,872 -0.5% geo. mean -0.1% minimum -0.5% maximum +0.0% ``` Fixes #23964. - - - - - a4f1a181 by Bryan Richter at 2023-10-10T19:02:37-04:00 rel_eng/upload.sh cleanups - - - - - 80705335 by doyougnu at 2023-10-10T19:03:18-04:00 ci: add javascript label rule This adds a rule which triggers the javascript job when the "javascript" label is assigned to an MR. - - - - - a2c0fff6 by Matthew Craven at 2023-10-10T19:03:54-04:00 Make 'wWarningFlagsDeps' include every WarningFlag Fixes #24071. - - - - - d055f099 by Jan Hrček at 2023-10-10T19:04:33-04:00 Fix pretty printing of overlap pragmas in TH splices (fixes #24074) - - - - - 0746b868 by Andreas Klebinger at 2023-10-10T19:05:09-04:00 Aarch64 NCG: Use encoded immediates for literals. Try to generate instr x2, <imm> instead of mov x1, lit instr x2, x1 When possible. This get's rid if quite a few redundant mov instructions. I believe this causes a metric decrease for LargeRecords as we reduce register pressure. ------------------------- Metric Decrease: LargeRecord ------------------------- - - - - - 739f4e6f by Andreas Klebinger at 2023-10-10T19:05:09-04:00 AArch NCG: Refactor getRegister' Remove some special cases which can be handled just as well by the generic case. This increases code re-use while also fixing #23749. Since some of the special case wasn't upholding Note [Signed arithmetic on AArch64]. - - - - - 1b213d33 by Andreas Klebinger at 2023-10-10T19:05:09-04:00 Aarch ncg: Optimize immediate use for address calculations When the offset doesn't fit into the immediate we now just reuse the general getRegister' code path which is well optimized to compute the offset into a register instead of a special case for CmmRegOff. This means we generate a lot less code under certain conditions which is why performance metrics for these improve. ------------------------- Metric Decrease: T4801 T5321FD T5321Fun ------------------------- - - - - - b7df0732 by John Ericson at 2023-10-11T16:02:11-04:00 RTS configure: Move over mem management checks These are for heap allocation, a strictly RTS concern. All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. The RTS configure one has a new ``` AC_CHECK_SIZEOF([void *]) ``` that the top-level configure version didn't have, so that `ac_cv_sizeof_void_p` is defined. Once more code is moved over in latter commits, that can go away. Progress towards #17191 - - - - - 41130a65 by John Ericson at 2023-10-11T16:02:11-04:00 RTS configure: Move over `__thread` check This used by (@bgamari thinks) the `GCThread` abstraction in the RTS. All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. Progress towards #17191 - - - - - cc5ec2bd by John Ericson at 2023-10-11T16:02:11-04:00 RTS configure: Move over misc function checks These are for general use in the RTS. All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. Progress towards #17191 - - - - - 809e7c2d by John Ericson at 2023-10-11T16:02:11-04:00 RTS configure: Move over `eventfd` check This check is for the RTS part of the event manager and has a corresponding part in `base`. All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. Progress towards #17191 - - - - - 58f3babf by John Ericson at 2023-10-11T16:02:48-04:00 Split `FP_CHECK_PTHREADS` and move part to RTS configure `NEED_PTHREAD_LIB` is unused since 3609340743c1b25fdfd0e18b1670dac54c8d8623 (part of the make build system), and so is no longer defined. Progress towards #17191 - - - - - e99cf237 by Moritz Angermann at 2023-10-11T16:03:24-04:00 nativeGen: section flags for .text$foo only Commit 3ece9856d157c85511d59f9f862ab351bbd9b38b, was supposed to fix #22834 in !9810. It does however add "xr" indiscriminatly to .text sections even if splitSections is disabled. This leads to the assembler saying: ghc_1.s:7849:0: error: Warning: Ignoring changed section attributes for .text | 7849 | .section .text,"xr" | ^ - - - - - f383a242 by Sylvain Henry at 2023-10-11T16:04:04-04:00 Modularity: pass TempDir instead of DynFlags (#17957) - - - - - 34fc28b0 by John Ericson at 2023-10-12T06:48:28-04:00 Test that functions from `mingwex` are available Ryan wrote these two minimizations, but they never got added to the test suite. See #23309, #23378 Co-Authored-By: Ben Gamari <bgamari.foss at gmail.com> Co-Authored-By: Ryan Scott <ryan.gl.scott at gmail.com> - - - - - bdb54a0e by John Ericson at 2023-10-12T06:48:28-04:00 Do not check for the `mingwex` library in `/configure` See the recent discussion in !10360 --- Cabal will itself check for the library for the packages that need it, and while the autoconf check additionally does some other things like define a `HAS_LIBMINGWEX` C Preprocessor macro, those other things are also unused and unneeded. Progress towards #17191, which aims to get rid of `/configure` entirely. - - - - - 43e814e1 by Ben Gamari at 2023-10-12T06:49:40-04:00 base: Introduce move modules into src The only non-move changes here are whitespace changes to pass the `whitespace` test and a few testsuite adaptations. - - - - - df81536f by Moritz Angermann at 2023-10-12T06:50:16-04:00 [PEi386 linker] Bounds check and null-deref guard We should resonably be able to expect that we won't exceed the number of sections if we assume to be dealing with legal object files. We can however not guarantee that we get some negative values, and while we try to special case most, we should exclude negative indexing into the sections array. We also need to ensure that we do not try to derefences targetSection, if it is NULL, due to the switch statement. - - - - - c74c4f00 by John Ericson at 2023-10-12T10:31:13-04:00 Move apple compat check to RTS configure - - - - - c80778ea by John Ericson at 2023-10-12T10:31:13-04:00 Move clock/timer fun checks to RTS configure Actual library check (which will set the Cabal flag) is left in the top-level configure for now. Progress towards #17191 - - - - - 7f9f2686 by John Ericson at 2023-10-12T10:31:13-04:00 Move visibility and "musttail" annotation checks to the RTS configure All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. Progress towards #17191 - - - - - ffb3efe6 by John Ericson at 2023-10-12T10:31:13-04:00 Move leading underscore checks to RTS configure `CabalLeadingUnderscore` is done via Hadrian already, so we can stop `AC_SUBST`ing it completely. - - - - - 25fa4b02 by John Ericson at 2023-10-12T10:31:13-04:00 Move alloca, fork, const, and big endian checks to RTS configure All of this should boil down to `AC_DEFINE` not `AC_SUBST`, so it belongs in the RTS configure and should be safe to move without modification. - - - - - 5170f42a by John Ericson at 2023-10-12T10:31:13-04:00 Move libdl check to RTS configure - - - - - ea7a1447 by John Ericson at 2023-10-12T10:31:13-04:00 Adjust `FP_FIND_LIBFFI` Just set vars, and `AC_SUBST` in top-level configure. Don't define `HAVE_SYSTEM_LIBFFI` because nothing is using it. It hasn't be in used since 3609340743c1b25fdfd0e18b1670dac54c8d8623 (part of the make build system). - - - - - f399812c by John Ericson at 2023-10-12T10:31:13-04:00 Split BFD support to RTS configure The flag is still in the top-level configure, but the other checks (which define various macros --- important) are in the RTS configure. - - - - - f64f44e9 by John Ericson at 2023-10-12T10:31:13-04:00 Split libm check between top level and RTS - - - - - dafc4709 by Moritz Angermann at 2023-10-12T10:31:49-04:00 CgUtils.fixStgRegStmt respect register width This change ensure that the reg + offset computation is always of the same size. Before this we could end up with a 64bit register, and then add a 32bit offset (on 32bit platforms). This not only would fail type sanity checking, but also incorrectly truncate 64bit values into 32bit values silently on 32bit architectures. - - - - - 9e6ef7ba by Matthew Pickering at 2023-10-12T20:35:00-04:00 hadrian: Decrease verbosity of cabal commands In Normal, most tools do not produce output to stdout unless there are error conditions. Reverts 7ed65f5a1bc8e040e318ccff395f53a9bbfd8217 - - - - - 08fc27af by John Ericson at 2023-10-12T20:35:36-04:00 Do not substitute `@...@` for stage-specific values in cabal files `rts` and `ghc-prim` now no longer have a `*.cabal.in` to set Cabal flag defaults; instead manual choices are passed to configure in the usual way. The old way was fundamentally broken, because it meant we were baking these Cabal files for a specific stage. Now we only do stage-agnostic @...@ substitution in cabal files (the GHC version), and so all stage-specific configuration is properly confined to `_build` and the right stage dir. Also `include-ghc-prim` is a flag that no longer exists for `ghc-prim` (it was removed in 835d8ddbbfb11796ea8a03d1806b7cee38ba17a6) so I got rid of it. Co-Authored-By: Matthew Pickering <matthewtpickering at gmail.com> - - - - - a0ac8785 by Sebastian Graf at 2023-10-14T19:17:12-04:00 Fix restarts in .ghcid Using the whole of `hadrian/` restarted in a loop for me. - - - - - fea9ecdb by Sebastian Graf at 2023-10-14T19:17:12-04:00 CorePrep: Refactor FloatingBind (#23442) A drastically improved architecture for local floating in CorePrep that decouples the decision of whether a float is going to be let- or case-bound from how far it can float (out of strict contexts, out of lazy contexts, to top-level). There are a couple of new Notes describing the effort: * `Note [Floating in CorePrep]` for the overview * `Note [BindInfo and FloatInfo]` for the new classification of floats * `Note [Floats and FloatDecision]` for how FloatInfo is used to inform floating decisions This is necessary ground work for proper treatment of Strict fields and unlifted values at top-level. Fixes #23442. NoFib results (omitted = 0.0%): ``` -------------------------------------------------------------------------------- Program Allocs Instrs -------------------------------------------------------------------------------- pretty 0.0% -1.6% scc 0.0% -1.7% -------------------------------------------------------------------------------- Min 0.0% -1.7% Max 0.0% -0.0% Geometric Mean -0.0% -0.0% ``` - - - - - 32523713 by Matthew Pickering at 2023-10-14T19:17:49-04:00 hadrian: Move ghcBinDeps into ghcLibDeps This completes a5227080b57cb51ac34d4c9de1accdf6360b818b, the `ghc-usage.txt` and `ghci-usage.txt` file are also used by the `ghc` library so need to make sure they are present in the libdir even if we are not going to build `ghc-bin`. This also fixes things for cross compilers because the stage2 cross-compiler requires the ghc-usage.txt file, but we are using the stage2 lib folder but not building stage3:exe:ghc-bin so ghc-usage.txt was not being generated. - - - - - ec3c4488 by sheaf at 2023-10-14T19:18:29-04:00 Combine GREs when combining in mkImportOccEnv In `GHC.Rename.Names.mkImportOccEnv`, we sometimes discard one import item in favour of another, as explained in Note [Dealing with imports] in `GHC.Rename.Names`. However, this can cause us to lose track of important parent information. Consider for example #24084: module M1 where { class C a where { type T a } } module M2 ( module M1 ) where { import M1 } module M3 where { import M2 ( C, T ); instance C () where T () = () } When processing the import list of `M3`, we start off (for reasons that are not relevant right now) with two `Avail`s attached to `T`, namely `C(C, T)` and `T(T)`. We combine them in the `combine` function of `mkImportOccEnv`; as described in Note [Dealing with imports] we discard `C(C, T)` in favour of `T(T)`. However, in doing so, we **must not** discard the information want that `C` is the parent of `T`. Indeed, losing track of this information can cause errors when importing, as we could get an error of the form ‘T’ is not a (visible) associated type of class ‘C’ We fix this by combining the two GREs for `T` using `plusGRE`. Fixes #24084 - - - - - 257c2807 by Ilias Tsitsimpis at 2023-10-14T19:19:07-04:00 hadrian: Pass -DNOSMP to C compiler when needed Hadrian passes the -DNOSMP flag to GHC when the target doesn't support SMP, but doesn't pass it to CC as well, leading to the following compilation error on mips64el: | Run Cc (FindCDependencies CDep) Stage1: rts/sm/NonMovingScav.c => _build/stage1/rts/build/c/sm/NonMovingScav.o.d Command line: /usr/bin/mips64el-linux-gnuabi64-gcc -E -MM -MG -MF _build/stage1/rts/build/c/hooks/FlagDefaults.thr_debug_p_o.d -MT _build/stage1/rts/build/c/hooks/FlagDefaults.o -Irts/include -I_build/stage1/rts/build -I_build/stage1/rts/build/include -Irts/include -x c rts/hooks/FlagDefaults.c -Wall -Wextra -Wstrict-prototypes -Wmissing-prototypes -Wmissing-declarations -Winline -Wpointer-arith -Wmissing-noreturn -Wnested-externs -Wredundant-decls -Wundef -fno-strict-aliasing -DTHREADED_RTS -DDEBUG -fomit-frame-pointer -O2 -g -Irts -I_build/stage1/rts/build -DDEBUG -fno-omit-frame-pointer -g3 -O0 ===> Command failed with error code: 1 In file included from rts/include/Stg.h:348, from rts/include/Rts.h:38, from rts/hooks/FlagDefaults.c:8: rts/include/stg/SMP.h:416:2: error: #error memory barriers unimplemented on this architecture 416 | #error memory barriers unimplemented on this architecture | ^~~~~ rts/include/stg/SMP.h:440:2: error: #error memory barriers unimplemented on this architecture 440 | #error memory barriers unimplemented on this architecture | ^~~~~ rts/include/stg/SMP.h:464:2: error: #error memory barriers unimplemented on this architecture 464 | #error memory barriers unimplemented on this architecture | ^~~~~ The old make system correctly passed this flag to both GHC and CC [1]. Fix this error by passing -DNOSMP to CC as well. [1] https://gitlab.haskell.org/ghc/ghc/-/blob/00920f176b0235d5bb52a8e054d89a664f8938fe/rts/ghc.mk#L407 Closes #24082 - - - - - 13d3c613 by John Ericson at 2023-10-14T19:19:42-04:00 Users Guide: Drop dead code for Haddock refs to `parallel` I noticed while working on !11451 that `@LIBRARY_parallel_UNIT_ID@` was not substituted. It is dead code -- there is no `parallel-ref` usages and it doesn't look like there ever was (going back to 3e5d0f188d6c8633e55e9ba6c8941c07e459fa4b), so let's delete it. - - - - - fe067577 by Sylvain Henry at 2023-10-18T19:40:25-04:00 Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066) bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a". - - - - - cc1625b1 by Sylvain Henry at 2023-10-18T19:40:25-04:00 Bignum: fix right shift of negative BigNat with native backend - - - - - cbe4400d by Sylvain Henry at 2023-10-18T19:40:25-04:00 Rts: expose rtsOutOfBoundsAccess symbol - - - - - 72c7380c by Sylvain Henry at 2023-10-18T19:40:25-04:00 Hadrian: enable `-fcheck-prim-bounds` in validate flavour This allows T24066 to fail when the bug is present. Otherwise the out-of-bound access isn't detected as it happens in ghc-bignum which wasn't compiled with the bounds check. - - - - - f9436990 by John Ericson at 2023-10-18T19:41:01-04:00 Make Hadrian solely responsible for substituting `docs/users_guide/ghc_config.py.in` Fixes #24091 Progress on #23966 Issue #24091 reports that `@ProjectVersion@` is no longer being substituted in the GHC user's guide. I assume this is a recent issue, but I am not sure how it's worked since c1a3ecde720b3bddc2c8616daaa06ee324e602ab; it looks like both Hadrian and configure are trying to substitute the same `.in` file! Now only Hadrian does. That is better anyways; already something that issue #23966 requested. It seems like we were missing some dependencies in Hadrian. (I really, really hate that this is possible!) Hopefully it is fixed now. - - - - - b12df0bb by John Ericson at 2023-10-18T19:41:37-04:00 `ghcversion.h`: No need to cope with undefined `ProjectPatchLevel*` Since 4e6c80197f1cc46dfdef0300de46847c7cfbdcb0, these are guaranteed to be defined. (Guaranteed including a test in the testsuite.) - - - - - 0295375a by John Ericson at 2023-10-18T19:41:37-04:00 Generate `ghcversion.h` from a `.in` file Now that there are no conditional sections (see the previous commit), we can just a do simple substitution rather than pasting it together line by line. Progress on #23966 - - - - - 740a1b85 by Krzysztof Gogolewski at 2023-10-19T11:37:20-04:00 Add a regression test for #24064 - - - - - 921fbf2f by Hécate Moonlight at 2023-10-19T11:37:59-04:00 CLC Proposal #182: Export List from Data.List Proposal link: https://github.com/haskell/core-libraries-committee/issues/182 - - - - - 4f02d3c1 by Sylvain Henry at 2023-10-20T04:01:32-04:00 rts: fix small argument passing on big-endian arch (fix #23387) - - - - - b86243b4 by Sylvain Henry at 2023-10-20T04:02:13-04:00 Interpreter: fix literal alignment on big-endian architectures (fix #19261) Literals weren't correctly aligned on big-endian, despite what the comment said. - - - - - a4b2ec47 by Sylvain Henry at 2023-10-20T04:02:54-04:00 Testsuite: recomp011 and recomp015 are fixed on powerpc These tests have been fixed but not tested and re-enabled on big-endian powerpc (see comments in #11260 and #11323) - - - - - fded7dd4 by Sebastian Graf at 2023-10-20T04:03:30-04:00 CorePrep: Allow floating dictionary applications in -O0 into a Rec (#24102) - - - - - 02efc181 by John Ericson at 2023-10-22T02:48:55-04:00 Move function checks to RTS configure Some of these functions are used in `base` too, but we can copy the checks over to its configure if that's an issue. - - - - - 5f4bccab by John Ericson at 2023-10-22T02:48:55-04:00 Move over a number of C-style checks to RTS configure - - - - - 5cf04f58 by John Ericson at 2023-10-22T02:48:55-04:00 Move/Copy more `AC_DEFINE` to RTS config Only exception is the LLVM version macros, which are used for GHC itself. - - - - - b8ce5dfe by John Ericson at 2023-10-22T02:48:55-04:00 Define `TABLES_NEXT_TO_CODE` in the RTS configure We create a new cabal flag to facilitate this. - - - - - 4a40271e by John Ericson at 2023-10-22T02:48:55-04:00 Configure scripts: `checkOS`: Make a bit more robust `mingw64` and `mingw32` are now both accepted for `OSMinGW32`. This allows us to cope with configs/triples that we haven't normalized extra being what GNU `config.sub` does. - - - - - 16bec0a0 by John Ericson at 2023-10-22T02:48:55-04:00 Generate `ghcplatform.h` from RTS configure We create a new cabal flag to facilitate this. - - - - - 7dfcab2f by John Ericson at 2023-10-22T02:48:55-04:00 Get rid of all mention of `mk/config.h` The RTS configure script is now solely responsible for managing its headers; the top level configure script does not help. - - - - - c1e3719c by Cheng Shao at 2023-10-22T02:49:33-04:00 rts: drop stale mentions of MIN_UPD_SIZE We used to have MIN_UPD_SIZE macro that describes the minimum reserved size for thunks, so that the thunk can be overwritten in place as indirections or blackholes. However, this macro has not been actually defined or used anywhere since a long time ago; StgThunkHeader already reserves a padding word for this purpose. Hence this patch which drops stale mentions of MIN_UPD_SIZE. - - - - - d24b0d85 by Andrew Lelechenko at 2023-10-22T02:50:11-04:00 base changelog: move non-backported entries from 4.19 section to 4.20 Neither !10933 (check https://hackage.haskell.org/package/base-4.19.0.0/docs/src/Text.Read.Lex.html#numberToRangedRational) nor !10189 (check https://hackage.haskell.org/package/base-4.19.0.0/docs/src/Data.List.NonEmpty.html#unzip) were backported to `base-4.19.0.0`. Moving them to `base-4.20.0.0` section. Also minor stylistic changes to other entries, bringing them to a uniform form. - - - - - de78b32a by Alan Zimmerman at 2023-10-23T09:09:41-04:00 EPA Some tweaks to annotations - Fix span for GRHS - Move TrailingAnns from last match to FunBind - Fix GADT 'where' clause span - Capture full range for a CaseAlt Match - - - - - d5a8780d by Simon Hengel at 2023-10-23T09:10:23-04:00 Update primitives.rst - - - - - 4d075924 by Josh Meredith at 2023-10-24T23:04:12+11:00 JS/userguide: add explanation of writing jsbits - - - - - 07ab5cc1 by Cheng Shao at 2023-10-24T15:40:32-04:00 testsuite: increase timeout of ghc-api tests for wasm32 ghc-api tests for wasm32 are more likely to timeout due to the large wasm module sizes, especially when testing with wasm native tail calls, given wasmtime's handling of tail call opcodes are suboptimal at the moment. It makes sense to increase timeout specifically for these tests on wasm32. This doesn't affect other targets, and for wasm32 we don't increase timeout for all tests, so not to risk letting major performance regressions slip through the testsuite. - - - - - 0d6acca5 by Greg Steuck at 2023-10-26T08:44:23-04:00 Explicitly require RLIMIT_AS before use in OSMem.c This is done elsewhere in the source tree. It also suddenly is required on OpenBSD. - - - - - 9408b086 by Sylvain Henry at 2023-10-26T08:45:03-04:00 Modularity: modularize external linker Decouple runLink from DynFlags to allow calling runLink more easily. This is preliminary work for calling Emscripten's linker (emcc) from our JavaScript linker. - - - - - e0f35030 by doyougnu at 2023-10-27T08:41:12-04:00 js: add JStg IR, remove unsaturated constructor - Major step towards #22736 and adding the optimizer in #22261 - - - - - 35587eba by Simon Peyton Jones at 2023-10-27T08:41:48-04:00 Fix a bug in tail calls with ticks See #24078 for the diagnosis. The change affects only the Tick case of occurrence analysis. It's a bit hard to test, so no regression test (yet anyway). - - - - - 9bc5cb92 by Matthew Craven at 2023-10-28T07:06:17-04:00 Teach tag-inference about SeqOp/seq# Fixes the STG/tag-inference analogue of #15226. Co-Authored-By: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - 34f06334 by Moritz Angermann at 2023-10-28T07:06:53-04:00 [PEi386] Mask SYM_TYPE_DUP_DISCARD in makeSymbolExtra 48e391952c17ff7eab10b0b1456e3f2a2af28a9b introduced `SYM_TYPE_DUP_DISCARD` to the bitfield. The linker however, failed to mask the `SYM_TYPE_DUP_DISCARD` value. Thus `== SYM_TYPE_CODE` comparisons easily failed. This lead to us relocating DATA lookups (GOT) into E8 (call) and E9 (jump) instructions. - - - - - 5b51b2a2 by Mario Blažević at 2023-10-28T07:07:33-04:00 Fix and test for issue #24111, TH.Ppr output of pattern synonyms - - - - - 723bc352 by Alan Zimmerman at 2023-10-30T20:36:41-04:00 EPA: print doc comments as normal comments And ignore the ones allocated in haddock processing. It does not guarantee that every original haddock-like comment appears in the output, as it discards ones that have no legal attachment point. closes #23459 - - - - - 21b76843 by Simon Peyton Jones at 2023-10-30T20:37:17-04:00 Fix non-termination bug in equality solver constraint left-to-right then right to left, forever. Easily fixed. - - - - - 270867ac by Sebastian Graf at 2023-10-30T20:37:52-04:00 ghc-toolchain: build with `-package-env=-` (#24131) Otherwise globally installed libraries (via `cabal install --lib`) break the build. Fixes #24131. - - - - - 7a90020f by Krzysztof Gogolewski at 2023-10-31T20:03:37-04:00 docs: fix ScopedTypeVariables example (#24101) The previous example didn't compile. Furthermore, it wasn't demonstrating the point properly. I have changed it to an example which shows that 'a' in the signature must be the same 'a' as in the instance head. - - - - - 49f69f50 by Krzysztof Gogolewski at 2023-10-31T20:04:13-04:00 Fix pretty-printing of type family dependencies "where" should be after the injectivity annotation. - - - - - 73c191c0 by Ben Gamari at 2023-10-31T20:04:49-04:00 gitlab-ci: Bump LLVM bootstrap jobs to Debian 12 As the Debian 10 images have too old an LLVM. Addresses #24056. - - - - - 5b0392e0 by Matthew Pickering at 2023-10-31T20:04:49-04:00 ci: Run aarch64 llvm backend job with "LLVM backend" label This brings it into line with the x86 LLVM backend job. - - - - - 9f9c9227 by Ryan Scott at 2023-11-01T09:19:12-04:00 More robust checking for DataKinds As observed in #22141, GHC was not doing its due diligence in catching code that should require `DataKinds` in order to use. Most notably, it was allowing the use of arbitrary data types in kind contexts without `DataKinds`, e.g., ```hs data Vector :: Nat -> Type -> Type where ``` This patch revamps how GHC tracks `DataKinds`. The full specification is written out in the `DataKinds` section of the GHC User's Guide, and the implementation thereof is described in `Note [Checking for DataKinds]` in `GHC.Tc.Validity`. In brief: * We catch _type_-level `DataKinds` violations in the renamer. See `checkDataKinds` in `GHC.Rename.HsType` and `check_data_kinds` in `GHC.Rename.Pat`. * We catch _kind_-level `DataKinds` violations in the typechecker, as this allows us to catch things that appear beneath type synonyms. (We do *not* want to do this in type-level contexts, as it is perfectly fine for a type synonym to mention something that requires DataKinds while still using the type synonym in a module that doesn't enable DataKinds.) See `checkValidType` in `GHC.Tc.Validity`. * There is now a single `TcRnDataKindsError` that classifies all manner of `DataKinds` violations, both in the renamer and the typechecker. The `NoDataKindsDC` error has been removed, as it has been subsumed by `TcRnDataKindsError`. * I have added `CONSTRAINT` is `isKindTyCon`, which is what checks for illicit uses of data types at the kind level without `DataKinds`. Previously, `isKindTyCon` checked for `Constraint` but not `CONSTRAINT`. This is inconsistent, given that both `Type` and `TYPE` were checked by `isKindTyCon`. Moreover, it thwarted the implementation of the `DataKinds` check in `checkValidType`, since we would expand `Constraint` (which was OK without `DataKinds`) to `CONSTRAINT` (which was _not_ OK without `DataKinds`) and reject it. Now both are allowed. * I have added a flurry of additional test cases that test various corners of `DataKinds` checking. Fixes #22141. - - - - - 575d7690 by Sylvain Henry at 2023-11-01T09:19:53-04:00 JS: fix FFI "wrapper" and "dynamic" Fix codegen and helper functions for "wrapper" and "dynamic" foreign imports. Fix tests: - ffi006 - ffi011 - T2469 - T4038 Related to #22363 - - - - - 81fb8885 by Alan Zimmerman at 2023-11-01T22:23:56-04:00 EPA: Use full range for Anchor This change requires a series of related changes, which must all land at the same time, otherwise all the EPA tests break. * Use the current Anchor end as prior end Use the original anchor location end as the source of truth for calculating print deltas. This allows original spacing to apply in most cases, only changed AST items need initial delta positions. * Add DArrow to TrailingAnn * EPA Introduce HasTrailing in ExactPrint Use [TrailingAnn] in enterAnn and remove it from ExactPrint (LocatedN RdrName) * In HsDo, put TrailingAnns at top of LastStmt * EPA: do not convert comments to deltas when balancing. * EPA: deal with fallout from getMonoBind * EPA fix captureLineSpacing * EPA print any comments in the span before exiting it * EPA: Add comments to AnchorOperation * EPA: remove AnnEofComment, it is no longer used Updates Haddock submodule - - - - - 03e82511 by Rodrigo Mesquita at 2023-11-01T22:24:32-04:00 Fix in docs regarding SSymbol, SNat, SChar (#24119) - - - - - 362cc693 by Matthew Pickering at 2023-11-01T22:25:08-04:00 hadrian: Update bootstrap plans (9.4.6, 9.4.7, 9.6.2, 9.6.3, 9.8.1) Updating the bootstrap plans with more recent GHC versions. - - - - - 00b9b8d3 by Matthew Pickering at 2023-11-01T22:25:08-04:00 ci: Add 9.8.1 bootstrap testing job - - - - - ef3d20f8 by Matthew Pickering at 2023-11-01T22:25:08-04:00 Compatibility with 9.8.1 as boot compiler This fixes several compatability issues when using 9.8.1 as the boot compiler. * An incorrect version guard on the stack decoding logic in ghc-heap * Some ghc-prim bounds need relaxing * ghc is no longer wired in, so we have to remove the -this-unit-id ghc call. Fixes #24077 - - - - - 6755d833 by Jaro Reinders at 2023-11-03T10:54:42+01:00 Add NCG support for common 64bit operations to the x86 backend. These used to be implemented via C calls which was obviously quite bad for performance for operations like simple addition. Co-authored-by: Andreas Klebinger - - - - - 0dfb1fa7 by Vladislav Zavialov at 2023-11-03T14:08:41-04:00 T2T in Expressions (#23738) This patch implements the T2T (term-to-type) transformation in expressions. Given a function with a required type argument vfun :: forall a -> ... the user can now call it as vfun (Maybe Int) instead of vfun (type (Maybe Int)) The Maybe Int argument is parsed and renamed as a term (HsExpr), but then undergoes a conversion to a type (HsType). See the new function expr_to_type in compiler/GHC/Tc/Gen/App.hs and Note [RequiredTypeArguments and the T2T mapping] Left as future work: checking for puns. - - - - - cc1c7c54 by Duncan Coutts at 2023-11-05T00:23:44-04:00 Add a test for I/O managers It tries to cover the cases of multiple threads waiting on the same fd for reading and multiple threads waiting for writing, including wait cancellation by async exceptions. It should work for any I/O manager, in-RTS or in-Haskell. Unfortunately it will not currently work for Windows because it relies on anonymous unix sockets. It could in principle be ported to use Windows named pipes. - - - - - 2e448f98 by Cheng Shao at 2023-11-05T00:23:44-04:00 Skip the IOManager test on wasm32 arch. The test relies on the sockets API which are not (yet) available. - - - - - fe50eb35 by Cheng Shao at 2023-11-05T00:24:20-04:00 compiler: fix eager blackhole symbol in wasm32 NCG - - - - - af771148 by Cheng Shao at 2023-11-05T00:24:20-04:00 testsuite: fix optasm tests for wasm32 - - - - - 1b90735c by Matthew Pickering at 2023-11-05T00:24:20-04:00 testsuite: Add wasm32 to testsuite arches with NCG The compiler --info reports that wasm32 compilers have a NCG, so we should agree with that here. - - - - - db9a6496 by Alan Zimmerman at 2023-11-05T00:24:55-04:00 EPA: make locA a function, not a field name And use it to generalise reLoc The following for the windows pipeline one. 5.5% Metric Increase: T5205 - - - - - 833e250c by Simon Peyton Jones at 2023-11-05T00:25:31-04:00 Update the unification count in wrapUnifierX Omitting this caused type inference to fail in #24146. This was an accidental omision in my refactoring of the equality solver. - - - - - e451139f by Andreas Klebinger at 2023-11-05T00:26:07-04:00 Remove an accidental git conflict marker from a comment. - - - - - 30baac7a by Tobias Haslop at 2023-11-06T10:50:32+00:00 Add laws relating between Foldable/Traversable with their Bi- superclasses See https://github.com/haskell/core-libraries-committee/issues/205 for discussion. This commit also documents that the tuple instances only satisfy the laws up to lazyness, similar to the documentation added in !9512. - - - - - df626f00 by Tobias Haslop at 2023-11-07T02:20:37-05:00 Elaborate on the quantified superclass of Bifunctor This was requested in the comment https://github.com/haskell/core-libraries-committee/issues/93#issuecomment-1597271700 for when Traversable becomes a superclass of Bitraversable, but similarly applies to Functor/Bifunctor, which already are in a superclass relationship. - - - - - 8217acb8 by Alan Zimmerman at 2023-11-07T02:21:12-05:00 EPA: get rid of l2l and friends Replace them with l2l to convert the location la2la to convert a GenLocated thing Updates haddock submodule - - - - - dd88a260 by Luite Stegeman at 2023-11-07T02:21:53-05:00 JS: remove broken newIdents from JStg Monad GHC.JS.JStg.Monad.newIdents was broken, resulting in duplicate identifiers being generated in h$c1, h$c2, ... . This change removes the broken newIdents. - - - - - 455524a2 by Matthew Craven at 2023-11-09T08:41:59-05:00 Create specially-solved DataToTag class Closes #20532. This implements CLC proposal 104: https://github.com/haskell/core-libraries-committee/issues/104 The design is explained in Note [DataToTag overview] in GHC.Tc.Instance.Class. This replaces the existing `dataToTag#` primop. These metric changes are not "real"; they represent Unique-related flukes triggering on a different set of jobs than they did previously. See also #19414. Metric Decrease: T13386 T8095 Metric Increase: T13386 T8095 Co-authored-by: Simon Peyton Jones <simon.peytonjones at gmail.com> - - - - - a05f4554 by Alan Zimmerman at 2023-11-09T08:42:35-05:00 EPA: get rid of glRR and friends in GHC/Parser.y With the HasLoc and HasAnnotation classes, we can replace a number of type-specific helper functions in the parser with polymorphic ones instead Metric Decrease: MultiLayerModulesTH_Make - - - - - 18498538 by Cheng Shao at 2023-11-09T16:58:12+00:00 ci: bump ci-images for wasi-sdk upgrade - - - - - 52c0fc69 by PHO at 2023-11-09T19:16:22-05:00 Don't assume the current locale is *.UTF-8, set the encoding explicitly primops.txt contains Unicode characters: > LC_ALL=C ./genprimopcode --data-decl < ./primops.txt > genprimopcode: <stdin>: hGetContents: invalid argument (cannot decode byte sequence starting from 226) Hadrian must also avoid using readFile' to read primops.txt because it tries to decode the file with a locale-specific encoding. - - - - - 7233b3b1 by PHO at 2023-11-09T19:17:01-05:00 Use '[' instead of '[[' because the latter is a Bash-ism It doesn't work on platforms where /bin/sh is something other than Bash. - - - - - 6dbab180 by Simon Peyton Jones at 2023-11-09T19:17:36-05:00 Add an extra check in kcCheckDeclHeader_sig Fix #24083 by checking for a implicitly-scoped type variable that is not actually bound. See Note [Disconnected type variables] in GHC.Tc.Gen.HsType For some reason, on aarch64-darwin we saw a 2.8% decrease in compiler allocations for MultiLayerModulesTH_Make; but 0.0% on other architectures. Metric Decrease: MultiLayerModulesTH_Make - - - - - 22551364 by Sven Tennie at 2023-11-11T06:35:22-05:00 AArch64: Delete unused LDATA pseudo-instruction Though there were consuming functions for LDATA, there were no producers. Thus, the removed code was "dead". - - - - - 2a0ec8eb by Alan Zimmerman at 2023-11-11T06:35:59-05:00 EPA: harmonise acsa and acsA in GHC/Parser.y With the HasLoc class, we can remove the acsa helper function, using acsA instead. - - - - - 7ae517a0 by Teo Camarasu at 2023-11-12T08:04:12-05:00 nofib: bump submodule This includes changes that: - fix building a benchmark with HEAD - remove a Makefile-ism that causes errors in bash scripts Resolves #24178 - - - - - 3f0036ec by Alan Zimmerman at 2023-11-12T08:04:47-05:00 EPA: Replace Anchor with EpaLocation An Anchor has a location and an operation, which is either that it is unchanged or that it has moved with a DeltaPos data Anchor = Anchor { anchor :: RealSrcSpan , anchor_op :: AnchorOperation } An EpaLocation also has either a location or a DeltaPos data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) | EpaDelta !DeltaPos ![LEpaComment] Now that we do not care about always having a location in the anchor, we remove Anchor and replace it with EpaLocation We do this with a type alias initially, to ease the transition. The alias will be removed in time. We also have helpers to reconstruct the AnchorOperation from an EpaLocation. This is also temporary. Updates Haddock submodule - - - - - a7492048 by Alan Zimmerman at 2023-11-12T13:43:07+00:00 EPA: get rid of AnchorOperation Now that the Anchor type is an alias for EpaLocation, remove AnchorOperation. Updates haddock submodule - - - - - 0745c34d by Andrew Lelechenko at 2023-11-13T16:25:07-05:00 Add since annotation for showHFloat - - - - - e98051a5 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 Suppress duplicate librares linker warning of new macOS linker Fixes #24167 XCode 15 introduced a new linker which warns on duplicate libraries being linked. To disable this warning, we pass -Wl,-no_warn_duplicate_libraries as suggested by Brad King in CMake issue #25297. This flag isn't necessarily available to other linkers on darwin, so we must only configure it into the CC linker arguments if valid. - - - - - c411c431 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Encoding test witnesses recent iconv bug is fragile A regression in the new iconv() distributed with XCode 15 and MacOS Sonoma causes the test 'encoding004' to fail in the CP936 roundrip. We mark this test as fragile until this is fixed upstream (rather than broken, since previous versions of iconv pass the test) See #24161 - - - - - ce7fe5a9 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Update to LC_ALL=C no longer being ignored in darwin MacOS seems to have fixed an issue where it used to ignore the variable `LC_ALL` in program invocations and default to using Unicode. Since the behaviour seems to be fixed to account for the locale variable, we mark tests that were previously broken in spite of it as fragile (since they now pass in recent macOS distributions) See #24161 - - - - - e6c803f7 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 darwin: Fix single_module is obsolete warning In XCode 15's linker, -single_module is the default and otherwise passing it as a flag results in a warning being raised: ld: warning: -single_module is obsolete This patch fixes this warning by, at configure time, determining whether the linker supports -single_module (which is likely false for all non-darwin linkers, and true for darwin linkers in previous versions of macOS), and using that information at runtime to decide to pass or not the flag in the invocation. Fixes #24168 - - - - - 929ba2f9 by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 testsuite: Skip MultiLayerModulesTH_Make on darwin The recent toolchain upgrade on darwin machines resulted in the MultiLayerModulesTH_Make test metrics varying too much from the baseline, ultimately blocking the CI pipelines. This commit skips the test on darwin to temporarily avoid failures due to the environment change in the runners. However, the metrics divergence is being investigated still (tracked in #24177) - - - - - af261ccd by Rodrigo Mesquita at 2023-11-15T13:18:58-05:00 configure: check target (not build) understands -no_compact_unwind Previously, we were branching on whether the build system was darwin to shortcut this check, but we really want to branch on whether the target system (which is what we are configuring ld_prog for) is darwin. - - - - - 2125c176 by Luite Stegeman at 2023-11-15T13:19:38-05:00 JS: Fix missing variable declarations The JStg IR update was missing some local variable declarations that were present earlier, causing global variables to be used implicitly (or an error in JavaScript strict mode). This adds the local variable declarations again. - - - - - 99ced73b by Krzysztof Gogolewski at 2023-11-15T13:20:14-05:00 Remove loopy superclass solve mechanism Programs with a -Wloopy-superclass-solve warning will now fail with an error. Fixes #23017 - - - - - 2aff2361 by Zubin Duggal at 2023-11-15T13:20:50-05:00 users-guide: Fix links to libraries from the users-guide. The unit-ids generated in c1a3ecde720b3bddc2c8616daaa06ee324e602ab include the package name, so we don't need to explicitly add it to the links. Fixes #24151 - - - - - 27981fac by Alan Zimmerman at 2023-11-15T13:21:25-05:00 EPA: splitLHsForAllTyInvis does not return ann We did not use the annotations returned from splitLHsForAllTyInvis, so do not return them. - - - - - a6467834 by Krzysztof Gogolewski at 2023-11-15T22:22:59-05:00 Document defaulting of RuntimeReps Fixes #24099 - - - - - 2776920e by Simon Peyton Jones at 2023-11-15T22:23:35-05:00 Second fix to #24083 My earlier fix turns out to be too aggressive for data/type families See wrinkle (DTV1) in Note [Disconnected type variables] - - - - - cee81370 by Sylvain Henry at 2023-11-16T09:57:46-05:00 Fix unusable units and module reexport interaction (#21097) This commit fixes an issue with ModUnusable introduced in df0f148feae. In mkUnusableModuleNameProvidersMap we traverse the list of unusable units and generate ModUnusable origin for all the modules they contain: exposed modules, hidden modules, and also re-exported modules. To do this we have a two-level map: ModuleName -> Unit:ModuleName (aka Module) -> ModuleOrigin So for each module name "M" in broken unit "u" we have: "M" -> u:M -> ModUnusable reason However in the case of module reexports we were using the *target* module as a key. E.g. if "u:M" is a reexport for "X" from unit "o": "M" -> o:X -> ModUnusable reason Case 1: suppose a reexport without module renaming (u:M -> o:M) from unusable unit u: "M" -> o:M -> ModUnusable reason Here it's claiming that the import of M is unusable because a reexport from u is unusable. But if unit o isn't unusable we could also have in the map: "M" -> o:M -> ModOrigin ... Issue: the Semigroup instance of ModuleOrigin doesn't handle the case (ModUnusable <> ModOrigin) Case 2: similarly we could have 2 unusable units reexporting the same module without renaming, say (u:M -> o:M) and (v:M -> o:M) with u and v unusable. It gives: "M" -> o:M -> ModUnusable ... (for u) "M" -> o:M -> ModUnusable ... (for v) Issue: the Semigroup instance of ModuleOrigin doesn't handle the case (ModUnusable <> ModUnusable). This led to #21097, #16996, #11050. To fix this, in this commit we make ModUnusable track whether the module used as key is a reexport or not (for better error messages) and we use the re-export module as key. E.g. if "u:M" is a reexport for "o:X" and u is unusable, we now record: "M" -> u:M -> ModUnusable reason reexported=True So now, we have two cases for a reexport u:M -> o:X: - u unusable: "M" -> u:M -> ModUnusable ... reexported=True - u usable: "M" -> o:X -> ModOrigin ... reexportedFrom=u:M The second case is indexed with o:X because in this case the Semigroup instance of ModOrigin is used to combine valid expositions of a module (directly or via reexports). Note that module lookup functions select usable modules first (those who have a ModOrigin value), so it doesn't matter if we add new ModUnusable entries in the map like this: "M" -> { u:M -> ModUnusable ... reexported=True o:M -> ModOrigin ... } The ModOrigin one will be used. Only if there is no ModOrigin or ModHidden entry will the ModUnusable error be printed. See T21097 for an example printing several reasons why an import is unusable. - - - - - 3e606230 by Krzysztof Gogolewski at 2023-11-16T09:58:22-05:00 Fix IPE test A helper function was defined in a different module than used. To reproduce: ./hadrian/build test --test-root-dirs=testsuite/tests/rts/ipe - - - - - 49f5264b by Andreas Klebinger at 2023-11-16T20:52:11-05:00 Properly compute unpacked sizes for -funpack-small-strict-fields. Use rep size rather than rep count to compute the size. Fixes #22309 - - - - - b4f84e4b by James Henri Haydon at 2023-11-16T20:52:53-05:00 Explicit methods for Alternative Compose Explicitly define some and many in Alternative instance for Data.Functor.Compose Implementation of https://github.com/haskell/core-libraries-committee/issues/181 - - - - - 9bc0dd1f by Ignat Insarov at 2023-11-16T20:53:34-05:00 Add permutations for non-empty lists. Approved by CLC in https://github.com/haskell/core-libraries-committee/issues/68#issuecomment-1221409837 - - - - - 5643ecf9 by Andrew Lelechenko at 2023-11-16T20:53:34-05:00 Update changelog and since annotations for Data.List.NonEmpty.permutations Approved by CLC in https://github.com/haskell/core-libraries-committee/issues/68#issuecomment-1221409837 - - - - - 94ff2134 by Oleg Alexander at 2023-11-16T20:54:15-05:00 Update doc string for traceShow Updated doc string for traceShow. - - - - - faff671a by Luite Stegeman at 2023-11-17T14:12:51+01:00 JS: clean up some foreign imports - - - - - 856e0a4e by Sven Tennie at 2023-11-18T06:54:11-05:00 AArch64: Remove unused instructions As these aren't ever emitted, we don't even know if they work or will ever be used. If one of them is needed in future, we may easily re-add it. Deleted instructions are: - CMN - ANDS - BIC - BICS - EON - ORN - ROR - TST - STP - LDP - DMBSY - - - - - 615441ef by Alan Zimmerman at 2023-11-18T06:54:46-05:00 EPA: Replace Monoid with NoAnn Remove the final Monoid instances in the exact print infrastructure. For Windows CI Metric Decrease: T5205 - - - - - 5a6c49d4 by David Feuer at 2023-11-20T18:53:18-05:00 Speed up stimes in instance Semigroup Endo As discussed at https://github.com/haskell/core-libraries-committee/issues/4 - - - - - cf9da4b3 by Andrew Lelechenko at 2023-11-20T18:53:18-05:00 base: reflect latest changes in the changelog - - - - - 48bf364e by Alan Zimmerman at 2023-11-20T18:53:54-05:00 EPA: Use SrcSpan in EpaSpan This is more natural, since we already need to deal with invalid RealSrcSpans, and that is exactly what SrcSpan.UnhelpfulSpan is for. Updates haddock submodule. - - - - - 97ec37cc by Sebastian Graf at 2023-11-20T18:54:31-05:00 Add regression test for #6070 Fixes #6070. - - - - - e9d5ae41 by Owen Shepherd at 2023-11-21T18:32:23-05:00 chore: Correct typo in the gitlab MR template [skip ci] - - - - - f158a8d0 by Rodrigo Mesquita at 2023-11-21T18:32:59-05:00 Improve error message when reading invalid `.target` files A `.target` file generated by ghc-toolchain or by configure can become invalid if the target representation (`Toolchain.Target`) is changed while the files are not re-generated by calling `./configure` or `ghc-toolchain` again. There is also the issue of hadrian caching the dependencies on `.target` files, which makes parsing fail when reading reading the cached value if the representation has been updated. This patch provides a better error message in both situations, moving away from a terrible `Prelude.read: no parse` error that you would get otherwise. Fixes #24199 - - - - - 955520c6 by Ben Gamari at 2023-11-21T18:33:34-05:00 users guide: Note that QuantifiedConstraints implies ExplicitForAll Fixes #24025. - - - - - 17ec3e97 by Owen Shepherd at 2023-11-22T09:37:28+01:00 fix: Change type signatures in NonEmpty export comments to reflect reality This fixes several typos in the comments of Data.List.NonEmpty export list items. - - - - - 2fd78f9f by Samuel Thibault at 2023-11-22T11:49:13-05:00 Fix the platform string for GNU/Hurd As commited in Cargo https://github.com/haskell/cabal/pull/9434 there is confusion between "gnu" and "hurd". This got fixed in Cargo, we need the converse in Hadrian. Fixes #24180 - - - - - a79960fe by Alan Zimmerman at 2023-11-22T11:49:48-05:00 EPA: Tuple Present no longer has annotation The Present constructor for a Tuple argument will never have an exact print annotation. So make this impossible. - - - - - 121c9ab7 by David Binder at 2023-11-22T21:12:29-05:00 Unify the hpc testsuites The hpc testsuite was split between testsuite/tests/hpc and the submodule libraries/hpc/test. This commit unifies the two testsuites in the GHC repository in the directory testsuite/tests/hpc. - - - - - d2733a05 by Alan Zimmerman at 2023-11-22T21:13:05-05:00 EPA: empty tup_tail has noAnn In Parser.y, the tup_tail rule had the following option | {- empty -} %shift { return [Left noAnn] } Once this works through PostProcess.hs, it means we add an extra Missing constructor if the last item was a comma. Change the annotation type to a Bool to indicate this, and use the EpAnn Anchor for the print location for the others. - - - - - fa576eb8 by Andreas Klebinger at 2023-11-24T08:29:13-05:00 Fix FMA primops generating broken assembly on x86. `genFMA3Code` assumed that we had to take extra precations to avoid overwriting the result of `getNonClobberedReg`. One of these special cases caused a bug resulting in broken assembly. I believe we don't need to hadle these cases specially at all, which means this MR simply deletes the special cases to fix the bug. Fixes #24160 - - - - - 34d86315 by Alan Zimmerman at 2023-11-24T08:29:49-05:00 EPA: Remove parenthesizeHsType This is called from PostProcess.hs, and adds spurious parens. With the looser version of exact printing we had before we could tolerate this, as they would be swallowed by the original at the same place. But with the next change (remove EpAnnNotUsed) they result in duplicates in the output. For Darwin build: Metric Increase: MultiLayerModulesTH_OneShot - - - - - 3ede659d by Vladislav Zavialov at 2023-11-26T06:43:32-05:00 Add name for -Wdeprecated-type-abstractions (#24154) This warning had no name or flag and was triggered unconditionally. Now it is part of -Wcompat. - - - - - 7902ebf8 by Alan Zimmerman at 2023-11-26T06:44:08-05:00 EPA: Remove EpAnnNotUsed We no longer need the EpAnnNotUsed constructor for EpAnn, as we can represent an unused annotation with an anchor having a EpaDelta of zero, and empty comments and annotations. This simplifies code handling annotations considerably. Updates haddock submodule Metric Increase: parsing001 - - - - - 471b2672 by Mario Blažević at 2023-11-26T06:44:48-05:00 Bumped the upper bound of text to <2.2 - - - - - d1bf25c7 by Vladislav Zavialov at 2023-11-26T11:45:49-05:00 Term variable capture (#23740) This patch changes type variable lookup rules (lookupTypeOccRn) and implicit quantification rules (filterInScope) so that variables bound in the term namespace can be captured at the type level {-# LANGUAGE RequiredTypeArguments #-} f1 x = g1 @x -- `x` used in a type application f2 x = g2 (undefined :: x) -- `x` used in a type annotation f3 x = g3 (type x) -- `x` used in an embedded type f4 x = ... where g4 :: x -> x -- `x` used in a type signature g4 = ... This change alone does not allow us to accept examples shown above, but at least it gets them past the renamer. - - - - - da863d15 by Vladislav Zavialov at 2023-11-26T11:46:26-05:00 Update Note [hsScopedTvs and visible foralls] The Note was written before GHC gained support for visible forall in types of terms. Rewrite a few sentences and use a better example. - - - - - b5213542 by Matthew Pickering at 2023-11-27T12:53:59-05:00 testsuite: Add mechanism to collect generic metrics * Generalise the metric logic by adding an additional field which allows you to specify how to query for the actual value. Previously the method of querying the baseline value was abstracted (but always set to the same thing). * This requires rejigging how the stat collection works slightly but now it's more uniform and hopefully simpler. * Introduce some new "generic" helper functions for writing generic stats tests. - collect_size ( deviation, path ) Record the size of the file as a metric - stat_from_file ( metric, deviation, path ) Read a value from the given path, and store that as a metric - collect_generic_stat ( metric, deviation, get_stat) Provide your own `get_stat` function, `lambda way: <Int>`, which can be used to establish the current value of the metric. - collect_generic_stats ( metric_info ): Like collect_generic_stat but provide the whole dictionary of metric definitions. { metric: { deviation: <Int> current: lambda way: <Int> } } * Introduce two new "size" metrics for keeping track of build products. - `size_hello_obj` - The size of `hello.o` from compiling hello.hs - `libdir` - The total size of the `libdir` folder. * Track the number of modules in the AST tests - CountDepsAst - CountDepsParser This lays the infrastructure for #24191 #22256 #17129 - - - - - 7d9a2e44 by ARATA Mizuki at 2023-11-27T12:54:39-05:00 x86: Don't require -mavx2 when using 256-bit floating-point SIMD primitives Fixes #24222 - - - - - 4e5ff6a4 by Alan Zimmerman at 2023-11-27T12:55:15-05:00 EPA: Remove SrcSpanAnn Now that we only have a single constructor for EpAnn, And it uses a SrcSpan for its location, we can do away with SrcSpanAnn completely. It only existed to wrap the original SrcSpan in a location, and provide a place for the exact print annotation. For darwin only: Metric Increase: MultiLayerModulesTH_OneShot Updates haddock submodule - - - - - e05bca39 by Krzysztof Gogolewski at 2023-11-28T08:00:55-05:00 testsuite: don't initialize testdir to '.' The test directory is removed during cleanup, if there's an interrupt that could remove the entire repository. Fixes #24219 - - - - - af881674 by Alan Zimmerman at 2023-11-28T08:01:30-05:00 EPA: Clean up mkScope in Ast.hs Now that we have HasLoc we can get rid of all the custom variants of mkScope For deb10-numa Metric Increase: libdir - - - - - 292983c8 by Ben Gamari at 2023-11-28T22:44:28-05:00 distrib: Rediscover otool and install_name_tool on Darwin In the bindist configure script we must rediscover the `otool` and `install_name_tool`s since they may be different from the build environment. Fixes #24211. - - - - - dfe1c354 by Stefan Schulze Frielinghaus at 2023-11-28T22:45:04-05:00 llvmGen: Align objects in the data section Objects in the data section may be referenced via tagged pointers. Thus, align those objects to a 4- or 8-byte boundary for 32- or 64-bit platforms, respectively. Note, this may need to be reconsidered if objects with a greater natural alignment requirement are emitted as e.g. 128-bit atomics. Fixes #24163. - - - - - f6c486c3 by Matthew Pickering at 2023-11-29T11:08:13-05:00 metrics: Widen libdir and size_hello_obj acceptance window af8816740d9b8759be1a22af8adcb5f13edeb61d shows that the libdir size can fluctuate quite significantly even when the change is quite small. Therefore we widen the acceptance window to 10%. - - - - - 99a6a49c by Alan Zimmerman at 2023-11-29T11:08:49-05:00 EPA: Clean up TC Monad Utils We no longer need the alternative variant of addLocM (addLocMA) nor wrapLocAM, wrapLocSndMA. aarch64-darwin Metric Increase: MultiLayerModulesTH_OneShot deb10-numa-slow Metric Decrease: libdir - - - - - cbc03fa0 by Sebastian Graf at 2023-11-30T12:37:21-05:00 perf tests: Move comments into new `Note [Sensitivity to unique increment]` (#19414) And additionally to T12545, link from T8095, T13386 to this new Note. - - - - - c7623b22 by Alan Zimmerman at 2023-11-30T12:37:56-05:00 EPA: EpaDelta for comment has no comments EpaLocation is used to position things. It has two constructors, EpaSpan holding a SrcSpan, and EpaDelta with a delta position and a possible list of comments. The comment list is needed because the location in EpaDelta has no absolute information to decide which comments should be emitted before them when printing. But it is also used for specifying the position of a comment. To prevent the absurdity of a comment position having a list of comments in it, we make EpaLocation parameterisable, using comments for the normal case and a constant for within comments. Updates haddock submodule. aarch64-darwin Metric Decrease: MultiLayerModulesTH_OneShot - - - - - bd8acc0c by Krzysztof Gogolewski at 2023-11-30T12:38:32-05:00 Kind-check body of a required forall We now require that in 'forall a -> ty', ty has kind TYPE r for some r. Fixes #24176 - - - - - 010fb784 by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - cda9c12d by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 495265b9 by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - d134d1de by Owen Shepherd at 2023-12-03T00:10:09-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - dfcf629c by Owen Shepherd at 2023-12-03T00:10:10-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - cad3b734 by Owen Shepherd at 2023-12-03T00:10:10-05:00 fix: Add missing property of List.group - - - - - bad37656 by Matthew Pickering at 2023-12-03T00:10:46-05:00 testsuite: Fix T21097b test with make 4.1 (deb9) cee81370cd6ef256f66035e3116878d4cb82e28b recently added a test which failed on deb9 because the version of make was emitting the recipe failure to stdout rather than stderr. One way to fix this is to be more precise in the test about which part of the output we care about inspecting. - - - - - 5efdf421 by Matthew Pickering at 2023-12-03T00:11:21-05:00 testsuite: Track size of libdir in bytes For consistency it's better if we track all size metrics in bytes. Metric Increase: libdir - - - - - f5eb0f29 by Matthew Pickering at 2023-12-03T00:11:22-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - d5610737 by Claudio Bley at 2023-12-06T16:13:33-05:00 Only exit ghci in -e mode when :add command fails Previously, when running `ghci -e ':add Sample.hs'` the process would exit with exit code 1 if the file exists and could be loaded. Fixes #24115 - - - - - 0f0c53a5 by Vladislav Zavialov at 2023-12-06T16:14:09-05:00 T2T in Patterns (#23739) This patch implements the T2T (term-to-type) transformation in patterns. Patterns that are checked against a visible forall can now be written without the `type` keyword: \(type t) (x :: t) -> ... -- old \t (x :: t) -> ... -- new The `t` binder is parsed and renamed as a term pattern (Pat), but then undergoes a conversion to a type pattern (HsTyPat). See the new function pat_to_type_pat in compiler/GHC/Tc/Gen/Pat.hs - - - - - 10a1a6c6 by Sebastian Graf at 2023-12-06T16:14:45-05:00 Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234) Before, the source location would point at the surrounding function definition, causing the confusion in #24234. I also took the opportunity to introduce a new `LazyPatCtx :: HsMatchContext _` to make the warning message say "irrefutable pattern" instead of "pattern binding". - - - - - 36b9a38c by Matthew Pickering at 2023-12-06T16:15:21-05:00 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 - - - - - 91ff0971 by Matthew Pickering at 2023-12-06T16:15:21-05:00 Submodule linter: Allow references to tags We modify the submodule linter so that if the bumped commit is a specific tag then the commit is accepted. Fixes #24241 - - - - - 86f652dc by Zubin Duggal at 2023-12-06T16:15:21-05:00 hadrian: set -Wno-deprecations for directory and Win32 The filepath bump to 1.4.200.1 introduces a deprecation warning. See https://gitlab.haskell.org/ghc/ghc/-/issues/24240 https://github.com/haskell/filepath/pull/206 - - - - - 7ac6006e by Sylvain Henry at 2023-12-06T16:16:02-05:00 Zap OccInfo on case binders during StgCse #14895 #24233 StgCse can revive dead binders: case foo of dead { Foo x y -> Foo x y; ... } ===> case foo of dead { Foo x y -> dead; ... } -- dead is no longer dead So we must zap occurrence information on case binders. Fix #14895 and #24233 - - - - - 57c391c4 by Sebastian Graf at 2023-12-06T16:16:37-05:00 Cpr: Turn an assertion into a check to deal with some dead code (#23862) See the new `Note [Dead code may contain type confusions]`. Fixes #23862. - - - - - c1c8abf8 by Zubin Duggal at 2023-12-08T02:25:07-05:00 testsuite: add test for #23944 - - - - - 6329d308 by Zubin Duggal at 2023-12-08T02:25:07-05:00 driver: Only run a dynamic-too pipeline if object files are going to be generated Otherwise we run into a panic in hscMaybeWriteIface: "Unexpected DT_Dyn state when writing simple interface" when dynamic-too is enabled We could remove the panic and just write the interface even if the state is `DT_Dyn`, but it seems pointless to run the pipeline twice when `hscMaybeWriteIface` is already designed to write both `hi` and `dyn_hi` files if dynamic-too is enabled. Fixes #23944. - - - - - 28811f88 by Simon Peyton Jones at 2023-12-08T05:47:18-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - fec7894f by Simon Peyton Jones at 2023-12-08T05:47:18-05:00 Make SpecConstr deal with casts better This patch does two things, to fix #23209: * It improves SpecConstr so that it no longer quantifies over coercion variables. See Note [SpecConstr and casts] * It improves the rule matcher to deal nicely with the case where the rule does not quantify over coercion variables, but the the template has a cast in it. See Note [Casts in the template] - - - - - 8db8d2fd by Zubin Duggal at 2023-12-08T05:47:54-05:00 driver: Don't lose track of nodes when we fail to resolve cycles The nodes that take part in a cycle should include both hs-boot and hs files, but when we fail to resolve a cycle, we were only counting the nodes from the graph without boot files. Fixes #24196 - - - - - c5b4efd3 by Zubin Duggal at 2023-12-08T05:48:30-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - fae472a9 by Wendao Lee at 2023-12-08T05:49:12-05:00 docs(Data.Char):Add more detailed descriptions for some functions Related changed function's docs: -GHC.Unicode.isAlpha -GHC.Unicode.isPrint -GHC.Unicode.isAlphaNum Add more details for what the function will return. Co-authored-by: Bodigrim <andrew.lelechenko at gmail.com> - - - - - ca7510e4 by Malik Ammar Faisal at 2023-12-08T05:49:55-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - d8baa1bd by Simon Peyton Jones at 2023-12-08T15:40:37+00:00 Take care when simplifying unfoldings This MR fixes a very subtle bug exposed by #24242. See Note [Environment for simplLetUnfolding]. I also updated a bunch of Notes on shadowing - - - - - 03ca551d by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Comments only in FloatIn Relevant to #3458 - - - - - 50c78779 by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Comments only in SpecConstr - - - - - 9431e195 by Simon Peyton Jones at 2023-12-08T15:54:50-05:00 Add test for #22238 - - - - - d9e4c597 by Vladislav Zavialov at 2023-12-11T04:19:34-05:00 Make forall a keyword (#23719) Before this change, GHC used to accept `forall` as a term-level identifier: -- from constraints-0.13 forall :: forall p. (forall a. Dict (p a)) -> Dict (Forall p) forall d = ... Now it is a parse error. The -Wforall-identifier warning has served its purpose and is now a deprecated no-op. - - - - - 58d56644 by Zubin Duggal at 2023-12-11T04:20:10-05:00 driver: Ensure we actually clear the interactive context before reloading Previously we called discardIC, but immediately after set the session back to an old HscEnv that still contained the IC Partially addresses #24107 Fixes #23405 - - - - - 8e5745a0 by Zubin Duggal at 2023-12-11T04:20:10-05:00 driver: Ensure we force the lookup of old build artifacts before returning the build plan This prevents us from retaining all previous build artifacts in memory until a recompile finishes, instead only retaining the exact artifacts we need. Fixes #24118 - - - - - 105c370c by Zubin Duggal at 2023-12-11T04:20:10-05:00 testsuite: add test for #24118 and #24107 MultiLayerModulesDefsGhci was not able to catch the leak because it uses :l which discards the previous environment. Using :r catches both of these leaks - - - - - e822ff88 by Zubin Duggal at 2023-12-11T04:20:10-05:00 compiler: Add some strictness annotations to ImportSpec and related constructors This prevents us from retaining entire HscEnvs. Force these ImportSpecs when forcing the GlobalRdrEltX Adds an NFData instance for Bag Fixes #24107 - - - - - 522c12a4 by Zubin Duggal at 2023-12-11T04:20:10-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 188b280d by Arnaud Spiwack at 2023-12-11T15:33:31+01:00 LinearTypes => MonoLocalBinds - - - - - 8e0446df by Arnaud Spiwack at 2023-12-11T15:44:28+01:00 Linear let and where bindings For expediency, the initial implementation of linear types in GHC made it so that let and where binders would always be considered unrestricted. This was rather unpleasant, and probably a big obstacle to adoption. At any rate, this was not how the proposal was designed. This patch fixes this infelicity. It was surprisingly difficult to build, which explains, in part, why it took so long to materialise. As of this patch, let or where bindings marked with %1 will be linear (respectively %p for an arbitrary multiplicity p). Unmarked let will infer their multiplicity. Here is a prototypical example of program that used to be rejected and is accepted with this patch: ```haskell f :: A %1 -> B g :: B %1 -> C h :: A %1 -> C h x = g y where y = f x ``` Exceptions: - Recursive let are unrestricted, as there isn't a clear semantics of what a linear recursive binding would be. - Destructive lets with lazy bindings are unrestricted, as their desugaring isn't linear (see also #23461). - (Strict) destructive lets with inferred polymorphic type are unrestricted. Because the desugaring isn't linear (See #18461 down-thread). Closes #18461 and #18739 Co-authored-by: @jackohughes - - - - - effa7e2d by Matthew Craven at 2023-12-12T04:37:20-05:00 Introduce `dataToTagSmall#` primop (closes #21710) ...and use it to generate slightly better code when dataToTag# is used at a "small data type" where there is no need to mess with "is_too_big_tag" or potentially look at an info table. Metric Decrease: T18304 - - - - - 35c7aef6 by Matthew Craven at 2023-12-12T04:37:20-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 7397c784 by Oleg Grenrus at 2023-12-12T04:37:56-05:00 Allow untyped brackets in typed splices and vice versa. Resolves #24190 Apparently the check was essentially always (as far as I can trace back: d0d47ba76f8f0501cf3c4966bc83966ab38cac27), and while it does catch some mismatches, the type-checker will catch them too. OTOH, it prevents writing completely reasonable programs. - - - - - a3ee3b99 by Moritz Angermann at 2023-12-12T19:50:58-05:00 Drop hard Xcode dependency XCODE_VERSION calls out to `xcodebuild`, which is only available when having `Xcode` installed. The CommandLineTools are not sufficient. To install Xcode, you must have an apple id to download the Xcode.xip from apple. We do not use xcodebuild anywhere in our build explicilty. At best it appears to be a proxy for checking the linker or the compiler. These should rather be done with ``` xcrun ld -version ``` or similar, and not by proxy through Xcode. The CLR should be sufficient for building software on macOS. - - - - - 1c9496e0 by Vladislav Zavialov at 2023-12-12T19:51:34-05:00 docs: update information on RequiredTypeArguments Update the User's Guide and Release Notes to account for the recent progress in the implementation of RequiredTypeArguments. - - - - - d0b17576 by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Fix off-by-one in assertion Previously we failed to account for the NULL terminator `postString` asserted that there is enough room in the buffer for the string. - - - - - a10f9b9b by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. - - - - - 0e0f41c0 by Ben Gamari at 2023-12-13T06:33:37-05:00 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. - - - - - 64e724c8 by Artin Ghasivand at 2023-12-13T06:34:20-05:00 Remove the "Derived Constraint" argument of TcPluginSolver, docs - - - - - fe6d97dd by Vladislav Zavialov at 2023-12-13T06:34:56-05:00 EPA: Move tokens into GhcPs extension fields (#23447) Summary of changes * Remove Language.Haskell.Syntax.Concrete * Move all tokens into GhcPs extension fields (LHsToken -> EpToken) * Create new TTG extension fields as needed * Drop the MultAnn wrapper Updates the haddock submodule. Co-authored-by: Alan Zimmerman <alan.zimm at gmail.com> - - - - - 8106e695 by Zubin Duggal at 2023-12-13T06:35:34-05:00 testsuite: use copy_files in T23405 This prevents the tree from being dirtied when the file is modified. - - - - - ed0e4099 by Bryan Richter at 2023-12-14T04:30:53-05:00 Document ghc package's PVP-noncompliance This changes nothing, it just makes the status quo explicit. - - - - - 8bef8d9f by Luite Stegeman at 2023-12-14T04:31:33-05:00 JS: Mark spurious CI failures js_fragile(24259) This marks the spurious test failures on the JS platform as js_fragile(24259), so we don't hold up merge requests while fixing the underlying issues. See #24259 - - - - - 1c79526a by Finley McIlwaine at 2023-12-15T12:24:40-08:00 Late plugins - - - - - 000c3302 by Finley McIlwaine at 2023-12-15T12:24:40-08:00 withTiming on LateCCs and late plugins - - - - - be4551ac by Finley McIlwaine at 2023-12-15T12:24:40-08:00 add test for late plugins - - - - - 7c29da9f by Finley McIlwaine at 2023-12-15T12:24:40-08:00 Document late plugins - - - - - 9a52ae46 by Ben Gamari at 2023-12-20T07:07:26-05:00 Fix thunk update ordering Previously we attempted to ensure soundness of concurrent thunk update by synchronizing on the access of the thunk's info table pointer field. This was believed to be sufficient since the indirectee (which may expose a closure allocated by another core) would not be examined until the info table pointer update is complete. However, it turns out that this can result in data races in the presence of multiple threads racing a update a single thunk. For instance, consider this interleaving under the old scheme: Thread A Thread B --------- --------- t=0 Enter t 1 Push update frame 2 Begin evaluation 4 Pause thread 5 t.indirectee=tso 6 Release t.info=BLACKHOLE 7 ... (e.g. GC) 8 Resume thread 9 Finish evaluation 10 Relaxed t.indirectee=x 11 Load t.info 12 Acquire fence 13 Inspect t.indirectee 14 Release t.info=BLACKHOLE Here Thread A enters thunk `t` but is soon paused, resulting in `t` being lazily blackholed at t=6. Then, at t=10 Thread A finishes evaluation and updates `t.indirectee` with a relaxed store. Meanwhile, Thread B enters the blackhole. Under the old scheme this would introduce an acquire-fence but this would only synchronize with Thread A at t=6. Consequently, the result of the evaluation, `x`, is not visible to Thread B, introducing a data race. We fix this by treating the `indirectee` field as we do all other mutable fields. This means we must always access this field with acquire-loads and release-stores. See #23185. - - - - - f4b53538 by Vladislav Zavialov at 2023-12-20T07:08:02-05:00 docs: Fix link to 051-ghc-base-libraries.rst The proposal is no longer available at the previous URL. - - - - - f7e21fab by Matthew Pickering at 2023-12-21T14:57:40+00:00 hadrian: Build all executables in bin/ folder In the end the bindist creation logic copies them all into the bin folder. There is no benefit to building a specific few binaries in the lib/bin folder anymore. This also removes the ad-hoc logic to copy the touchy and unlit executables from stage0 into stage1. It takes <1s to build so we might as well just build it. - - - - - 0038d052 by Zubin Duggal at 2023-12-22T23:28:00-05:00 testsuite: mark jspace as fragile on i386. This test has been flaky for some time and has been failing consistently on i386-linux since 8e0446df landed. See #24261 - - - - - dfd670a0 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 609e6225 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 865513b2 by Ömer Sinan Ağacan at 2023-12-24T10:11:13-05:00 Fix BNF in user manual 6.6.8.2: formal syntax for instance declarations - - - - - c247b6be by Zubin Duggal at 2023-12-25T16:01:23-05:00 docs: document permissibility of -XOverloadedLabels (#24249) Document the permissibility introduced by https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst - - - - - e5b7eb59 by Ömer Sinan Ağacan at 2023-12-25T16:02:03-05:00 Fix a code block syntax in user manual sec. 6.8.8.6 - - - - - 2db11c08 by Ben Gamari at 2023-12-29T15:35:48-05:00 genSym: Reimplement via CAS on 32-bit platforms Previously the remaining use of the C implementation on 32-bit platforms resulted in a subtle bug, #24261. This was due to the C object (which used the RTS's `atomic_inc64` macro) being compiled without `-threaded` yet later being used in a threaded compiler. Side-step this issue by using the pure Haskell `genSym` implementation on all platforms. This required implementing `fetchAddWord64Addr#` in terms of CAS on 64-bit platforms. - - - - - 19328a8c by Xiaoyan Ren at 2023-12-29T15:36:30-05:00 Do not color the diagnostic code in error messages (#24172) - - - - - 685b467c by Krzysztof Gogolewski at 2023-12-29T15:37:06-05:00 Enforce that bindings of implicit parameters are lifted Fixes #24298 - - - - - bc4d67b7 by Matthew Craven at 2023-12-31T06:15:42-05:00 StgToCmm: Detect some no-op case-continuations ...and generate no code for them. Fixes #24264. - - - - - 5b603139 by Krzysztof Gogolewski at 2023-12-31T06:16:18-05:00 Revert "testsuite: mark jspace as fragile on i386." This reverts commit 0038d052c8c80b4b430bb2aa1c66d5280be1aa95. The atomicity bug should be fixed by !11802. - - - - - d55216ad by Krzysztof Gogolewski at 2024-01-01T12:05:49-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 8b340bc7 by Ömer Sinan Ağacan at 2024-01-01T12:06:29-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - b938fef1 by Teo Camarasu at 2024-01-03T10:31:44+00:00 nonmoving: Add support for heap profiling Add support for heap profiling while using the nonmoving collector. We greatly simply the implementation by disabling concurrent collection for GCs when heap profiling is enabled. This entails that the marked objects on the nonmoving heap are exactly the live objects. Note that we match the behaviour for live bytes accounting by taking the size of objects on the nonmoving heap to be that of the segment's block rather than the object itself. Resolves #22221 - - - - - 30 changed files: - .ghcid - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/issue_templates/bug.md → .gitlab/issue_templates/default.md - .gitlab/jobs.yaml - .gitlab/merge_request_templates/Default.md - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/upload.sh - .gitlab/rel_eng/upload_ghc_libs.py - .gitlab/test-metrics.sh - compiler/CodeGen.Platform.h - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/Cmm/DebugBlock.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/AArch64.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Cond.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/AArch64/Regs.hs - compiler/GHC/CmmToAsm/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/PPC/Instr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be774b770801802a5c05428f254df80adb7eb441...b938fef15e863aa7fb338dc12599b2ade6e62186 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be774b770801802a5c05428f254df80adb7eb441...b938fef15e863aa7fb338dc12599b2ade6e62186 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 10:57:58 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 05:57:58 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Refactor: store [[PrimRep]] rather than [Type] in STG Message-ID: <65953db643cf_146b144d18edc79526@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d55216ad by Krzysztof Gogolewski at 2024-01-01T12:05:49-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 8b340bc7 by Ömer Sinan Ağacan at 2024-01-01T12:06:29-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - 5d53e28b by Zubin Duggal at 2024-01-03T05:57:28-05:00 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 - - - - - 493460bf by Krzysztof Gogolewski at 2024-01-03T05:57:28-05:00 Refactor: remove calls to typePrimRepArgs The function typePrimRepArgs is just a thin wrapper around typePrimRep, adding a VoidRep if the list is empty. However, in StgToByteCode, we were discarding that VoidRep anyway, so there's no point in calling it. - - - - - 6 changed files: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - docs/users_guide/exts/kind_signatures.rst Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -141,8 +141,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic import Control.Monad (ap) -import Data.Maybe (fromMaybe) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -531,8 +530,10 @@ coreToStgApp f args ticks = do res_ty = exprType (mkApps (Var f) args) app = case idDetails f of DataConWorkId dc - | saturated -> StgConApp dc NoNumber args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + | saturated -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber args' (sumPrimReps args) + else + StgConApp dc NoNumber args' [] -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps @@ -560,6 +561,16 @@ coreToStgApp f args ticks = do -- profiling for #4367 app `seq` return tapp + +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -310,7 +310,7 @@ for the details of this transformation. | StgConApp DataCon ConstructorNumber [StgArg] -- Saturated. See Note [Constructor applications in STG] - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -166,8 +166,8 @@ avoid #19645. Other alternatives considered include: way to fix what is ultimately a corner-case. -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term: (# 123 | #) @@ -180,9 +180,21 @@ type of this term. For example, these are all valid tuples for this: (# 1#, 123, rubbish, rubbish #) -- when type is (# Int | (# Int, Int, Int #) #) -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. + +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. Note [Casting slot arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -527,7 +539,7 @@ unariseExpr rho (StgConApp dc n args ty_args) -> return $ (mkTuple args') | otherwise = let args' = unariseConArgs rho args in - return $ (StgConApp dc n args' (map stgArgType args')) + return $ (StgConApp dc n args' []) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -572,7 +584,7 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] -> ( [OutStgArg] -- Arguments representing the unboxed sum , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them -- into the right Rep @@ -860,7 +872,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = -- -- Example, for (# x | #) :: (# (# #) | Int #) we call -- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] -- -- which returns -- @@ -869,7 +881,7 @@ mkCast arg_in cast_op out_id out_ty in_rhs = mkUbxSum :: HasDebugCallStack => DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments @@ -877,7 +889,7 @@ mkUbxSum ) mkUbxSum dc ty_args args0 us = let - _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) tag = dataConTag dc @@ -1121,7 +1133,7 @@ isUnboxedTupleBndr :: Id -> Bool isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] tagAltTy :: AltType tagAltTy = PrimAlt IntRep ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -83,7 +83,6 @@ import Data.IntMap (IntMap) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -297,11 +296,6 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -495,11 +489,9 @@ returnUnliftedAtom -> StgArg -> BcM BCInstrList returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i + let reps = stgArgRep e (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -512,9 +504,7 @@ returnUnliftedReps returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of + ret <- case reps of -- use RETURN for nullary/unary representations [] -> return (unitOL $ RETURN V) [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) @@ -549,10 +539,12 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components + let non_void VoidRep = False + non_void _ = True ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) + (filter non_void $ map atomPrimRep es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -866,7 +858,7 @@ doCase d s p scrut bndr alts -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + non_void_arg_reps = typeArgReps platform bndr_ty ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 @@ -899,7 +891,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = typePrimRep (idType bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1695,19 +1687,15 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep + case typePrimRep r_ty of + [] -> Nothing + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -2147,7 +2135,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var + typePrimRep . idType $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2160,10 +2148,6 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) - repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2214,8 +2198,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== docs/users_guide/exts/kind_signatures.rst ===================================== @@ -37,6 +37,10 @@ This extension enables kind signatures in the following places: data Set (cxt :: Type -> Type) a = Set [a] +- ``newtype`` declarations: :: + + newtype Set (cxt :: Type -> Type) a = Set [a] + - ``type`` declarations: :: type T (f :: Type -> Type) = f Int View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/efe9bca30f7f989d28485332434f4ea236e57111...493460bf77f708cbe81acfc31e7213c451174ae2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/efe9bca30f7f989d28485332434f4ea236e57111...493460bf77f708cbe81acfc31e7213c451174ae2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 15:18:22 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 10:18:22 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: ci: Ensure we use the correct bindist name for the test artifact when generating Message-ID: <65957abeb5290_27396d15e44481047c@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9315d001 by Zubin Duggal at 2024-01-03T10:18:13-05:00 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 - - - - - 68154c83 by Krzysztof Gogolewski at 2024-01-03T10:18:14-05:00 Refactor: remove calls to typePrimRepArgs The function typePrimRepArgs is just a thin wrapper around typePrimRep, adding a VoidRep if the list is empty. However, in StgToByteCode, we were discarding that VoidRep anyway, so there's no point in calling it. - - - - - 9e250896 by mmzk1526 at 2024-01-03T10:18:16-05:00 Use "-V" for alex version check for better backward compatibility Fixes #24302. In recent versions of alex, "-v" is used for "--verbose" instead of "-version". - - - - - 3 changed files: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/StgToByteCode.hs - m4/fptools_alex.m4 Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -141,8 +141,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -83,7 +83,6 @@ import Data.IntMap (IntMap) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -297,11 +296,6 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -495,11 +489,9 @@ returnUnliftedAtom -> StgArg -> BcM BCInstrList returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i + let reps = stgArgRep e (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -512,9 +504,7 @@ returnUnliftedReps returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of + ret <- case reps of -- use RETURN for nullary/unary representations [] -> return (unitOL $ RETURN V) [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) @@ -549,10 +539,12 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components + let non_void VoidRep = False + non_void _ = True ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) + (filter non_void $ map atomPrimRep es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -866,7 +858,7 @@ doCase d s p scrut bndr alts -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + non_void_arg_reps = typeArgReps platform bndr_ty ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 @@ -899,7 +891,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = typePrimRep (idType bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1695,19 +1687,15 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep + case typePrimRep r_ty of + [] -> Nothing + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -2147,7 +2135,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var + typePrimRep . idType $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2160,10 +2148,6 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) - repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2214,8 +2198,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== m4/fptools_alex.m4 ===================================== @@ -14,7 +14,7 @@ AC_SUBST(AlexCmd,$ALEX) AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, changequote(, )dnl [if test x"$AlexCmd" != x; then - fptools_cv_alex_version=`"$AlexCmd" -v | + fptools_cv_alex_version=`"$AlexCmd" -V | grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; else fptools_cv_alex_version=""; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/493460bf77f708cbe81acfc31e7213c451174ae2...9e250896c9959b1d79b3e80ee29cbfe09afcdb8e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/493460bf77f708cbe81acfc31e7213c451174ae2...9e250896c9959b1d79b3e80ee29cbfe09afcdb8e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 18:10:58 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 03 Jan 2024 13:10:58 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports-2] Update release notes for 9.6.4 Message-ID: <6595a33267236_27396d5c5b0843005b@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports-2 at Glasgow Haskell Compiler / GHC Commits: 615a63d3 by Zubin Duggal at 2024-01-03T23:40:38+05:30 Update release notes for 9.6.4 Metric Decrease: MultiLayerModulesTH_Make - - - - - 1 changed file: - docs/users_guide/9.6.4-notes.rst Changes: ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -42,6 +42,8 @@ Compiler variables (:ghc-ticket:`24083`). - Fix a bug where certain warning flags were not recognised (:ghc-ticket:`24071`). - Fix an incorrect assertion in the simplifier (:ghc-ticket:`23862`). +- Align objects in the data section properly when using the LLVM backend + (:ghc-ticket:`24163`). Runtime system -------------- @@ -64,6 +66,8 @@ Build system and packaging :ghc-ticket:`24033`). - Fix a bug where ``-DNOSMP`` wasn't being passed to the C compiler even if the target doesn't support SMP (:ghc-ticket:`24082`). +- Ensure we use the right ``otool`` and ``install_name_tool`` on Darwin + (:ghc-ticket:`24211`). Core libraries -------------- @@ -75,6 +79,7 @@ Core libraries - Bump ``filepath`` to 1.4.200.1 - Bump ``unix`` to 2.8.4.0 - Bump ``haddock`` to 2.29.2 +- Bump ``bytestring`` to 0.11.5.3 Included libraries ------------------ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/615a63d39ecbeba863199d0447c975ea53a4c84c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/615a63d39ecbeba863199d0447c975ea53a4c84c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 18:18:42 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 13:18:42 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: ci: Ensure we use the correct bindist name for the test artifact when generating Message-ID: <6595a50281217_27396d5de2240328e8@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b209d9ae by Zubin Duggal at 2024-01-03T13:18:33-05:00 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 - - - - - 32a777ba by Krzysztof Gogolewski at 2024-01-03T13:18:34-05:00 Refactor: remove calls to typePrimRepArgs The function typePrimRepArgs is just a thin wrapper around typePrimRep, adding a VoidRep if the list is empty. However, in StgToByteCode, we were discarding that VoidRep anyway, so there's no point in calling it. - - - - - b9a261eb by mmzk1526 at 2024-01-03T13:18:37-05:00 Use "-V" for alex version check for better backward compatibility Fixes #24302. In recent versions of alex, "-v" is used for "--verbose" instead of "-version". - - - - - 3 changed files: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/StgToByteCode.hs - m4/fptools_alex.m4 Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -141,8 +141,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -83,7 +83,6 @@ import Data.IntMap (IntMap) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -297,11 +296,6 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -495,11 +489,9 @@ returnUnliftedAtom -> StgArg -> BcM BCInstrList returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i + let reps = stgArgRep e (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -512,9 +504,7 @@ returnUnliftedReps returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of + ret <- case reps of -- use RETURN for nullary/unary representations [] -> return (unitOL $ RETURN V) [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) @@ -549,10 +539,12 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components + let non_void VoidRep = False + non_void _ = True ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) + (filter non_void $ map atomPrimRep es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -866,7 +858,7 @@ doCase d s p scrut bndr alts -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + non_void_arg_reps = typeArgReps platform bndr_ty ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 @@ -899,7 +891,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = typePrimRep (idType bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1695,19 +1687,15 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep + case typePrimRep r_ty of + [] -> Nothing + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -2147,7 +2135,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var + typePrimRep . idType $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2160,10 +2148,6 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) - repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2214,8 +2198,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== m4/fptools_alex.m4 ===================================== @@ -14,7 +14,7 @@ AC_SUBST(AlexCmd,$ALEX) AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, changequote(, )dnl [if test x"$AlexCmd" != x; then - fptools_cv_alex_version=`"$AlexCmd" -v | + fptools_cv_alex_version=`"$AlexCmd" -V | grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; else fptools_cv_alex_version=""; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e250896c9959b1d79b3e80ee29cbfe09afcdb8e...b9a261eb7855cae677e86e516181beac3b7fb43d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9e250896c9959b1d79b3e80ee29cbfe09afcdb8e...b9a261eb7855cae677e86e516181beac3b7fb43d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 19:26:32 2024 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Wed, 03 Jan 2024 14:26:32 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] 17 commits: hadrian: Build all executables in bin/ folder Message-ID: <6595b4e86e7f7_27396d7e635c843493@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: f7e21fab by Matthew Pickering at 2023-12-21T14:57:40+00:00 hadrian: Build all executables in bin/ folder In the end the bindist creation logic copies them all into the bin folder. There is no benefit to building a specific few binaries in the lib/bin folder anymore. This also removes the ad-hoc logic to copy the touchy and unlit executables from stage0 into stage1. It takes <1s to build so we might as well just build it. - - - - - 0038d052 by Zubin Duggal at 2023-12-22T23:28:00-05:00 testsuite: mark jspace as fragile on i386. This test has been flaky for some time and has been failing consistently on i386-linux since 8e0446df landed. See #24261 - - - - - dfd670a0 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 609e6225 by Ben Bellick at 2023-12-24T10:10:31-05:00 Deprecate -ddump-json and introduce -fdiagnostics-as-json Addresses #19278 This commit deprecates the underspecified -ddump-json flag and introduces a newer, well-specified flag -fdiagnostics-as-json. Also included is a JSON schema as part of the documentation. The -ddump-json flag will be slated for removal shortly after this merge. - - - - - 865513b2 by Ömer Sinan Ağacan at 2023-12-24T10:11:13-05:00 Fix BNF in user manual 6.6.8.2: formal syntax for instance declarations - - - - - c247b6be by Zubin Duggal at 2023-12-25T16:01:23-05:00 docs: document permissibility of -XOverloadedLabels (#24249) Document the permissibility introduced by https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst - - - - - e5b7eb59 by Ömer Sinan Ağacan at 2023-12-25T16:02:03-05:00 Fix a code block syntax in user manual sec. 6.8.8.6 - - - - - 2db11c08 by Ben Gamari at 2023-12-29T15:35:48-05:00 genSym: Reimplement via CAS on 32-bit platforms Previously the remaining use of the C implementation on 32-bit platforms resulted in a subtle bug, #24261. This was due to the C object (which used the RTS's `atomic_inc64` macro) being compiled without `-threaded` yet later being used in a threaded compiler. Side-step this issue by using the pure Haskell `genSym` implementation on all platforms. This required implementing `fetchAddWord64Addr#` in terms of CAS on 64-bit platforms. - - - - - 19328a8c by Xiaoyan Ren at 2023-12-29T15:36:30-05:00 Do not color the diagnostic code in error messages (#24172) - - - - - 685b467c by Krzysztof Gogolewski at 2023-12-29T15:37:06-05:00 Enforce that bindings of implicit parameters are lifted Fixes #24298 - - - - - bc4d67b7 by Matthew Craven at 2023-12-31T06:15:42-05:00 StgToCmm: Detect some no-op case-continuations ...and generate no code for them. Fixes #24264. - - - - - 5b603139 by Krzysztof Gogolewski at 2023-12-31T06:16:18-05:00 Revert "testsuite: mark jspace as fragile on i386." This reverts commit 0038d052c8c80b4b430bb2aa1c66d5280be1aa95. The atomicity bug should be fixed by !11802. - - - - - d55216ad by Krzysztof Gogolewski at 2024-01-01T12:05:49-05:00 Refactor: store [[PrimRep]] rather than [Type] in STG StgConApp stored a list of types. This list was used exclusively during unarisation of unboxed sums (mkUbxSum). However, this is at a wrong level of abstraction: STG shouldn't be concerned with Haskell types, only PrimReps. Update the code to store a [[PrimRep]]. Also, there's no point in storing this list when we're not dealing with an unboxed sum. - - - - - 8b340bc7 by Ömer Sinan Ağacan at 2024-01-01T12:06:29-05:00 Kind signatures docs: mention that they're allowed in newtypes - - - - - 51d0d11a by Alan Zimmerman at 2024-01-03T18:20:43+00:00 EPA: Move EpAnn out of extension points Leaving a few that are too tricky, maybe some other time. Updates haddock submodule - - - - - 6b01dde7 by Alan Zimmerman at 2024-01-03T19:02:09+00:00 EPA: Remove some unneeded helpers from Parser.y info: patch template saved to `-` - - - - - 5c4e114e by Alan Zimmerman at 2024-01-03T19:02:10+00:00 EPA: Tackling extra parser allocations stats fail - make all getCommentsFor results strict. - adding `seq` to various Parser.y helper functions This metric increases 2.6% (6% before the mitigations in this commit) I think the balance are inherent to the change in GhcPs structure, it is a pathological case with HsAppTy repeating thousands of times. Metric Increase: parsing001 - - - - - 15 changed files: - compiler/GHC/CoreToStg.hs - compiler/GHC/Driver/Config/Logger.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68b81ce36fccec5297b6abccb4535ba11e17ca23...5c4e114ec99f285092d57b47a52926f244deccc0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/68b81ce36fccec5297b6abccb4535ba11e17ca23...5c4e114ec99f285092d57b47a52926f244deccc0 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 21:30:26 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Wed, 03 Jan 2024 16:30:26 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24306 Message-ID: <6595d1f2a3452_27396db1dbf54469aa@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/T24306 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24306 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Wed Jan 3 22:15:51 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 03 Jan 2024 17:15:51 -0500 Subject: [Git][ghc/ghc][ghc-9.6] 6 commits: docs: document permissibility of -XOverloadedLabels (#24249) Message-ID: <6595dc9762f78_36f0ddc622068339@gitlab.mail> Zubin pushed to branch ghc-9.6 at Glasgow Haskell Compiler / GHC Commits: c08f898a by Zubin Duggal at 2024-01-03T13:01:39+05:30 docs: document permissibility of -XOverloadedLabels (#24249) Document the permissibility introduced by https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0170-unrestricted-overloadedlabels.rst (cherry picked from commit c247b6befe6a599688bad0a3383424f7ea12d5f2) - - - - - a138877d by Stefan Schulze Frielinghaus at 2024-01-03T13:21:32+05:30 llvmGen: Align objects in the data section Objects in the data section may be referenced via tagged pointers. Thus, align those objects to a 4- or 8-byte boundary for 32- or 64-bit platforms, respectively. Note, this may need to be reconsidered if objects with a greater natural alignment requirement are emitted as e.g. 128-bit atomics. Fixes #24163. (cherry picked from commit dfe1c3540e4b519b62b862b5966dfec5cae9ece1) - - - - - 496fbe2e by Ben Gamari at 2024-01-03T13:21:32+05:30 distrib: Rediscover otool and install_name_tool on Darwin In the bindist configure script we must rediscover the `otool` and `install_name_tool`s since they may be different from the build environment. Fixes #24211. (cherry picked from commit 292983c841b4facd5c48fcec9689448d66bcb90e) - - - - - b8544fe8 by Matthew Craven at 2024-01-03T13:21:32+05:30 Bump bytestring submodule to 0.11.5.3 (cherry picked from commit 97a187bfd713663fccb8bc4f4f0c92792547f9c2) - - - - - 45c8117a by Zubin Duggal at 2024-01-03T13:21:32+05:30 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 (cherry picked from commit 0c555b74f3d9fa92423aebc768c3626a632203a8) - - - - - 615a63d3 by Zubin Duggal at 2024-01-03T23:40:38+05:30 Update release notes for 9.6.4 Metric Decrease: MultiLayerModulesTH_Make - - - - - 7 changed files: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/CmmToLlvm/Data.hs - distrib/configure.ac.in - docs/users_guide/9.6.4-notes.rst - docs/users_guide/exts/overloaded_labels.rst - libraries/bytestring - testsuite/tests/ghci/scripts/all.T Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -134,8 +134,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url ===================================== compiler/GHC/CmmToLlvm/Data.hs ===================================== @@ -89,6 +89,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do align = case sec of Section CString _ -> if (platformArch platform == ArchS390X) then Just 2 else Just 1 + Section Data _ -> Just $ platformWordSizeInBytes platform _ -> Nothing const = if sectionProtection sec == ReadOnlySection then Constant else Global ===================================== distrib/configure.ac.in ===================================== @@ -202,6 +202,18 @@ dnl Identify C++ standard library flavour and location FP_FIND_CXX_STD_LIB AC_CONFIG_FILES([mk/system-cxx-std-lib-1.0.conf]) +dnl ** Which otool to use on macOS +dnl -------------------------------------------------------------- +AC_CHECK_TARGET_TOOL([OTOOL], [otool]) +OtoolCmd="$OTOOL" +AC_SUBST(OtoolCmd) + +dnl ** Which install_name_tool to use on macOS +dnl -------------------------------------------------------------- +AC_CHECK_TARGET_TOOL([INSTALL_NAME_TOOL], [install_name_tool]) +InstallNameToolCmd="$INSTALL_NAME_TOOL" +AC_SUBST(InstallNameToolCmd) + dnl ** Set up the variables for the platform in the settings file. dnl May need to use gcc to find platform details. dnl -------------------------------------------------------------- ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -42,6 +42,8 @@ Compiler variables (:ghc-ticket:`24083`). - Fix a bug where certain warning flags were not recognised (:ghc-ticket:`24071`). - Fix an incorrect assertion in the simplifier (:ghc-ticket:`23862`). +- Align objects in the data section properly when using the LLVM backend + (:ghc-ticket:`24163`). Runtime system -------------- @@ -64,6 +66,8 @@ Build system and packaging :ghc-ticket:`24033`). - Fix a bug where ``-DNOSMP`` wasn't being passed to the C compiler even if the target doesn't support SMP (:ghc-ticket:`24082`). +- Ensure we use the right ``otool`` and ``install_name_tool`` on Darwin + (:ghc-ticket:`24211`). Core libraries -------------- @@ -75,6 +79,7 @@ Core libraries - Bump ``filepath`` to 1.4.200.1 - Bump ``unix`` to 2.8.4.0 - Bump ``haddock`` to 2.29.2 +- Bump ``bytestring`` to 0.11.5.3 Included libraries ------------------ ===================================== docs/users_guide/exts/overloaded_labels.rst ===================================== @@ -91,4 +91,69 @@ showing how an overloaded label can be used as a record selector: example = #x (Point 1 2) +Since GHC 9.6, any non-empty double quoted string can be used as a label. The +restriction that the label must be a valid identifier has also been lifted. +Examples of newly allowed syntax: + +- Leading capital letters: `#Foo` equivalant to `getLabel @"Foo"` + +- Numeric characters: `#3.14` equivalent to `getLabel @"3.14"` + +- Arbitrary strings: `#"Hello, World!"` equivalent to `getLabel @"Hello, World!"` + +Here is an example of the more permissive use of this extension, available since +GHC 9.6: + +:: + + {-# LANGUAGE DataKinds #-} + {-# LANGUAGE MultiParamTypeClasses #-} + {-# LANGUAGE OverloadedLabels #-} + {-# LANGUAGE MagicHash #-} + + import Data.Foldable (traverse_) + import Data.Proxy (Proxy(..)) + import GHC.OverloadedLabels (IsLabel(..)) + import GHC.TypeLits (KnownSymbol, symbolVal) + import GHC.Prim (Addr#) + + instance KnownSymbol symbol => IsLabel symbol String where + fromLabel = symbolVal (Proxy :: Proxy symbol) + + (#) :: String -> Int -> String + (#) _ i = show i + + f :: Addr# -> Int -> String + f _ i = show i + + main :: IO () + main = traverse_ putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #199.4 + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #... + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello#world + , (++) #"hello"#"world" + , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] + +See `GHC Proposal #170 `__ +for more details. ===================================== libraries/bytestring ===================================== @@ -1 +1 @@ -Subproject commit e377f49b046c986184cf802c8c6386b04c1f1aeb +Subproject commit 248bab33a07bfbab69f4bfcf853332a59953eeaf ===================================== testsuite/tests/ghci/scripts/all.T ===================================== @@ -57,7 +57,11 @@ test('ghci024', test('T9367', [req_interp, when(fast() or config.os != 'mingw32', skip)], makefile_test, []) -test('ghci025', extra_files(['Ghci025B.hs', 'Ghci025C.hs', 'Ghci025D.hs']), ghci_script, ['ghci025.script']) +test('ghci025', + [ extra_files(['Ghci025B.hs', 'Ghci025C.hs', 'Ghci025D.hs']), + normalise_version("bytestring")], + ghci_script, + ['ghci025.script']), test('ghci026', extra_files(['../prog002']), ghci_script, ['ghci026.script']) test('ghci027', [], ghci_script, ['ghci027.script']) @@ -216,7 +220,7 @@ test('T9762', , pre_cmd('$MAKE -s --no-print-directory T9762_prep') ], ghci_script, ['T9762.script']) -test('T9881', normal, ghci_script, ['T9881.script']) +test('T9881', normalise_version("bytestring"), ghci_script, ['T9881.script']) test('T9878', [], ghci_script, ['T9878.script']) test('T9878b', [extra_run_opts('-fobject-code')], ghci_script, ['T9878b.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/908c485f27b62961cb2798a373958f5c73734beb...615a63d39ecbeba863199d0447c975ea53a4c84c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/908c485f27b62961cb2798a373958f5c73734beb...615a63d39ecbeba863199d0447c975ea53a4c84c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 01:09:18 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 20:09:18 -0500 Subject: [Git][ghc/ghc][master] ci: Ensure we use the correct bindist name for the test artifact when generating Message-ID: <6596053e5dda0_36f0d556c9f877164@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 989bf8e5 by Zubin Duggal at 2024-01-03T20:08:47-05:00 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 - - - - - 1 changed file: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -141,8 +141,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989bf8e53c08eb22de716901b914b3607bc8dd08 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/989bf8e53c08eb22de716901b914b3607bc8dd08 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 01:09:50 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 20:09:50 -0500 Subject: [Git][ghc/ghc][master] Refactor: remove calls to typePrimRepArgs Message-ID: <6596055ebd12a_36f0d5708154800f1@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 89299a89 by Krzysztof Gogolewski at 2024-01-03T20:09:23-05:00 Refactor: remove calls to typePrimRepArgs The function typePrimRepArgs is just a thin wrapper around typePrimRep, adding a VoidRep if the list is empty. However, in StgToByteCode, we were discarding that VoidRep anyway, so there's no point in calling it. - - - - - 1 changed file: - compiler/GHC/StgToByteCode.hs Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -83,7 +83,6 @@ import Data.IntMap (IntMap) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -297,11 +296,6 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -495,11 +489,9 @@ returnUnliftedAtom -> StgArg -> BcM BCInstrList returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i + let reps = stgArgRep e (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -512,9 +504,7 @@ returnUnliftedReps returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of + ret <- case reps of -- use RETURN for nullary/unary representations [] -> return (unitOL $ RETURN V) [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) @@ -549,10 +539,12 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components + let non_void VoidRep = False + non_void _ = True ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) + (filter non_void $ map atomPrimRep es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -866,7 +858,7 @@ doCase d s p scrut bndr alts -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + non_void_arg_reps = typeArgReps platform bndr_ty ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 @@ -899,7 +891,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = typePrimRep (idType bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -1695,19 +1687,15 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep + case typePrimRep r_ty of + [] -> Nothing + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -2147,7 +2135,7 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var + typePrimRep . idType $ var | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) bcIdArgRep :: Platform -> Id -> ArgRep @@ -2160,10 +2148,6 @@ bcIdPrimRep id | otherwise = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) - repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2214,8 +2198,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89299a89c1ccb534cd4f68106ea8c606c34a4df8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89299a89c1ccb534cd4f68106ea8c606c34a4df8 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 01:10:42 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 03 Jan 2024 20:10:42 -0500 Subject: [Git][ghc/ghc][master] Use "-V" for alex version check for better backward compatibility Message-ID: <65960592ceee1_36f0d58ef850846cf@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c7be0c68 by mmzk1526 at 2024-01-03T20:10:07-05:00 Use "-V" for alex version check for better backward compatibility Fixes #24302. In recent versions of alex, "-v" is used for "--verbose" instead of "-version". - - - - - 1 changed file: - m4/fptools_alex.m4 Changes: ===================================== m4/fptools_alex.m4 ===================================== @@ -14,7 +14,7 @@ AC_SUBST(AlexCmd,$ALEX) AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, changequote(, )dnl [if test x"$AlexCmd" != x; then - fptools_cv_alex_version=`"$AlexCmd" -v | + fptools_cv_alex_version=`"$AlexCmd" -V | grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; else fptools_cv_alex_version=""; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7be0c680d96ba6209c86e509ab2682e5041a53d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7be0c680d96ba6209c86e509ab2682e5041a53d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 02:10:38 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Wed, 03 Jan 2024 21:10:38 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/voidrep-refactor Message-ID: <6596139e860ac_36f0d76749c0850ce@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/voidrep-refactor at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/voidrep-refactor You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 09:32:41 2024 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Thu, 04 Jan 2024 04:32:41 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/js-taginference Message-ID: <65967b3948da4_57c6e6104e643078e@gitlab.mail> Josh Meredith pushed new branch wip/js-taginference at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/js-taginference You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 10:10:43 2024 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Thu, 04 Jan 2024 05:10:43 -0500 Subject: [Git][ghc/ghc][wip/js-taginference] Lint Message-ID: <659684238cb0d_57c6e71522d034370@gitlab.mail> Josh Meredith pushed to branch wip/js-taginference at Glasgow Haskell Compiler / GHC Commits: 7109d412 by Josh Meredith at 2024-01-04T21:10:33+11:00 Lint - - - - - 1 changed file: - compiler/GHC/StgToJS/ExprCtx.hs Changes: ===================================== compiler/GHC/StgToJS/ExprCtx.hs ===================================== @@ -41,7 +41,6 @@ import GHC.Prelude import GHC.StgToJS.Types import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Id View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7109d4121f47ad119e50ea6ba23d88d58d41fa95 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7109d4121f47ad119e50ea6ba23d88d58d41fa95 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 10:25:23 2024 From: gitlab at gitlab.haskell.org (Josh Meredith (@JoshMeredith)) Date: Thu, 04 Jan 2024 05:25:23 -0500 Subject: [Git][ghc/ghc][wip/js-taginference] Lint Message-ID: <65968793b10f6_57c6e730eefc388c6@gitlab.mail> Josh Meredith pushed to branch wip/js-taginference at Glasgow Haskell Compiler / GHC Commits: 066a88ca by Josh Meredith at 2024-01-04T21:25:09+11:00 Lint - - - - - 1 changed file: - compiler/GHC/StgToJS/Utils.hs Changes: ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Types.ForeignCall import GHC.Types.TyThing import GHC.Types.Name @@ -433,11 +432,11 @@ isInlineExpr = \case ->let ie = isInlineExpr e ias = map isInlineExpr (fmap alt_rhs alts) in (ie || ctxIsEvaluated b) && and ias - StgLet _ b e + StgLet _ _ e -> isInlineExpr e - StgLetNoEscape _ _b e + StgLetNoEscape _ _ e -> isInlineExpr e - StgTick _ e + StgTick _ e -> isInlineExpr e isInlineForeignCall :: ForeignCall -> Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/066a88ca2bb194e00a9433dfaa07099c18635c81 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/066a88ca2bb194e00a9433dfaa07099c18635c81 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 10:37:25 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Thu, 04 Jan 2024 05:37:25 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/dmdanal-annotation-state Message-ID: <65968a6529059_57c6e7d9123039164@gitlab.mail> Sebastian Graf pushed new branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dmdanal-annotation-state You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 10:47:39 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Thu, 04 Jan 2024 05:47:39 -0500 Subject: [Git][ghc/ghc][wip/dmdanal-annotation-state] DmdAnal: Explicit annotation state Message-ID: <65968ccb7344f_57c6e809c5743936@gitlab.mail> Sebastian Graf pushed to branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC Commits: bd9bd454 by Sebastian Graf at 2024-01-04T11:47:16+01:00 DmdAnal: Explicit annotation state - - - - - 5 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,22 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +440,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +489,64 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds - alt_ty3 + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () + + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +559,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +620,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +986,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1046,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isRuntimeVar lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1099,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1231,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1905,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1925,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1935,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -2034,19 +2018,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2149,63 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2318,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2403,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2420,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2445,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2469,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2577,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2676,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad ( guard, zipWithM_ ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -432,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd9bd4540fb47a3548f131bc7de2dd29a63e247b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd9bd4540fb47a3548f131bc7de2dd29a63e247b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 11:55:12 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 04 Jan 2024 06:55:12 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/24310 Message-ID: <65969ca0e85fa_3def44825e24154c@gitlab.mail> Zubin pushed new branch wip/24310 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24310 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 11:57:00 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 04 Jan 2024 06:57:00 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/9.6.4-metadata-fail Message-ID: <65969d0cc8503_3def448f398c3330@gitlab.mail> Zubin pushed new branch wip/9.6.4-metadata-fail at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/9.6.4-metadata-fail You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 13:21:41 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Thu, 04 Jan 2024 08:21:41 -0500 Subject: [Git][ghc/ghc][wip/T24306] Fix VoidRep handling in ghci debugger Message-ID: <6596b0e4e275c_3def443024394156ec@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T24306 at Glasgow Haskell Compiler / GHC Commits: 8c4ff9b5 by Krzysztof Gogolewski at 2024-01-04T14:21:04+01:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - 5 changed files: - compiler/GHC/Runtime/Heap/Inspect.hs - + testsuite/tests/ghci.debugger/scripts/T24306.hs - + testsuite/tests/ghci.debugger/scripts/T24306.script - + testsuite/tests/ghci.debugger/scripts/T24306.stdout - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== testsuite/tests/ghci.debugger/scripts/T24306.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-} +module T24306 where + +import GHC.Exts + +newtype A = MkA (# #) +data T = T Int# A Int# + +x = T 1# (MkA (# #)) 2# ===================================== testsuite/tests/ghci.debugger/scripts/T24306.script ===================================== @@ -0,0 +1,2 @@ +:load T24306 +:force x ===================================== testsuite/tests/ghci.debugger/scripts/T24306.stdout ===================================== @@ -0,0 +1 @@ +x = T 1 (MkA (##)) 2 ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -140,3 +140,4 @@ test('break030', ['break030.script'], ) test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script']) +test('T24306', normal, ghci_script, ['T24306.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c4ff9b5a89fb74c6ccb86591969d8c6c66fe14b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c4ff9b5a89fb74c6ccb86591969d8c6c66fe14b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 15:46:28 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 Jan 2024 10:46:28 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ci: Ensure we use the correct bindist name for the test artifact when generating Message-ID: <6596d2d437260_3def446cb3a6c243f9@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 989bf8e5 by Zubin Duggal at 2024-01-03T20:08:47-05:00 ci: Ensure we use the correct bindist name for the test artifact when generating release ghcup metadata Fixes #24268 - - - - - 89299a89 by Krzysztof Gogolewski at 2024-01-03T20:09:23-05:00 Refactor: remove calls to typePrimRepArgs The function typePrimRepArgs is just a thin wrapper around typePrimRep, adding a VoidRep if the list is empty. However, in StgToByteCode, we were discarding that VoidRep anyway, so there's no point in calling it. - - - - - c7be0c68 by mmzk1526 at 2024-01-03T20:10:07-05:00 Use "-V" for alex version check for better backward compatibility Fixes #24302. In recent versions of alex, "-v" is used for "--verbose" instead of "-version". - - - - - 762f70af by Krzysztof Gogolewski at 2024-01-04T10:46:13-05:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - ff515cd4 by Krzysztof Gogolewski at 2024-01-04T10:46:13-05:00 VoidRep-related refactor * In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep, bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1. All of them were duplicates. * In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out. * In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out VoidRep from the result of typePrimRep. But typePrimRep never returns VoidRep - remove the filtering. - - - - - 15 changed files: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - m4/fptools_alex.m4 - + testsuite/tests/ghci.debugger/scripts/T24306.hs - + testsuite/tests/ghci.debugger/scripts/T24306.script - + testsuite/tests/ghci.debugger/scripts/T24306.stdout - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -141,8 +141,14 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # In --release-mode, the URL in the metadata needs to point into the downloads folder # rather then the pipeline. if release_mode: + # the test artifact is bundled with the source artifact, so it doesn't have its own job name + # So we must manually set the name of the bindist location + if artifact == test_artifact: + bindist_name = "testsuite" + else + bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version - , bindistName=urllib.parse.quote_plus(f"{fetch_gitlab.job_triple(artifact.job_name)}.tar.xz")) + , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) else: final_url = url ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -381,9 +381,9 @@ lintStgAppReps fun args = do | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep which can be either an empty list *or* [VoidRep] - -- No, typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. + -- Check for void rep (empty list) + -- Note typePrimRep_maybe will never return a result containing VoidRep. + -- We should refactor to make this obvious from the types. | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left @@ -410,7 +410,6 @@ lintStgAppReps fun args = do text "unarised?:" <> ppr (lf_unarised lf)) where isVoidRep [] = True - isVoidRep [VoidRep] = True isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -808,15 +808,13 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] id_vars = [v | StgVarArg v <- id_arg_exprs] - -- Output types for the field binders based on their rep - id_tys = map primRepToType fld_reps - typed_id_arg_input = assert (equalLength id_vars id_tys) $ - zip3 id_vars id_tys uss + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss - mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,tar_type,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -834,7 +832,7 @@ mapSumIdBinders alt_bndr args rhs rho0 typed_id_args = map StgVarArg typed_ids -- pprTrace "mapSumIdBinders" - -- (text "id_tys" <+> ppr id_tys $$ + -- (text "fld_reps" <+> ppr fld_reps $$ -- text "id_args" <+> ppr id_arg_exprs $$ -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts @@ -925,8 +923,7 @@ mkUbxSum dc ty_args args0 us castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRep1 arg - , out_ty <- primRepToType $ slotPrimRep slot_ty - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty + , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,9 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, + addIdReps, addArgReps, + nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap @@ -80,10 +82,8 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE import qualified GHC.Data.FiniteMap as Map import Data.Ord import GHC.Stack.CCS @@ -297,11 +297,6 @@ argBits platform (rep : args) | isFollowableArg rep = False : argBits platform args | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -378,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap - bits = argBits platform (reverse (map (bcIdArgRep platform) all_args)) + bits = argBits platform (reverse (map (idArgRep platform) all_args)) bitmap_size = genericLength bits bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -495,11 +490,9 @@ returnUnliftedAtom -> StgArg -> BcM BCInstrList returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i + let reps = stgArgRep e (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) + ret <- returnUnliftedReps d s szb reps return (push `appOL` ret) -- return an unlifted value from the top of the stack @@ -512,9 +505,7 @@ returnUnliftedReps returnUnliftedReps d s szb reps = do profile <- getProfile let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of + ret <- case reps of -- use RETURN for nullary/unary representations [] -> return (unitOL $ RETURN V) [rep] -> return (unitOL $ RETURN (toArgRep platform rep)) @@ -538,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (atomPrimRep e) + arg_ty e = primRepCmmType platform (stgArgRep1 e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -549,10 +540,12 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components + let non_void VoidRep = False + non_void _ = True ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) + (filter non_void $ map stgArgRep1 es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -753,11 +746,7 @@ mkConAppCode orig_d _ p con args = app_code let platform = profilePlatform profile non_voids = - [ NonVoid (prim_rep, arg) - | arg <- args - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] + addArgReps (nonVoidStgArgs args) (_, _, args_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader non_voids @@ -866,7 +855,7 @@ doCase d s p scrut bndr alts -- have the same runtime rep. We have more efficient specialized -- return frames for the situations with one non-void element. - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + non_void_arg_reps = typeArgReps platform bndr_ty ubx_tuple_frame = (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 @@ -899,7 +888,7 @@ doCase d s p scrut bndr alts (bndr_size, call_info, args_offsets) | ubx_tuple_frame = let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) + bndr_reps = typePrimRep (idType bndr) (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps in ( wordsToBytes platform (nativeCallSize call_info) @@ -939,7 +928,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . bcIdPrimRep + let bndr_ty = primRepCmmType platform . idPrimRep tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -955,7 +944,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ bcIdPrimRep arg)] + , not (isVoidRep $ idPrimRep arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -964,9 +953,7 @@ doCase d s p scrut bndr alts | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = mkVirtHeapOffsets profile NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] + (addIdReps (nonVoidIds real_bndrs)) size = WordOff tot_wds stack_bot = d_alts + wordsToBytes platform size @@ -1060,7 +1047,7 @@ doCase d s p scrut bndr alts rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p spread id offset | isUnboxedTupleType (idType id) || isUnboxedSumType (idType id) = Nothing - | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) | otherwise = Nothing where rel_offset = bytesToWords platform (d - offset) @@ -1486,7 +1473,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args return ((code, AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep aa) : rest) + return ((code_a, stgArgRep1 aa) : rest) code_n_reps <- pargs d0 args_r_to_l let @@ -1695,19 +1682,15 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep + case typePrimRep r_ty of + [] -> Nothing + [rep] -> Just rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack - _ -> blargh + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -2138,7 +2121,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup idSizeW :: Platform -> Id -> WordOff -idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform idSizeCon :: Platform -> Id -> ByteOff idSizeCon platform var @@ -2147,22 +2130,8 @@ idSizeCon platform var isUnboxedSumType (idType var) = wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var - | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) - -bcIdArgRep :: Platform -> Id -> ArgRep -bcIdArgRep platform = toArgRep platform . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | rep :| [] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) + typePrimRep . idType $ var + | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2201,12 +2170,8 @@ mkSlideW !n !ws -atomPrimRep :: StgArg -> PrimRep -atomPrimRep (StgVarArg v) = bcIdPrimRep v -atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) - atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (atomPrimRep e) +atomRep platform e = toArgRep platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack @@ -2214,8 +2179,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e) mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep -- ----------------------------------------------------------------------------- -- The bytecode generator's monad ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -257,7 +257,7 @@ cgDataCon mn data_con arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) - , not (isVoidRep rep_ty) ] + ] ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -328,10 +328,10 @@ getArgRepsAmodes args = do platform <- profilePlatform <$> getProfile mapM (getArgRepAmode platform) args where getArgRepAmode platform arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep platform (stgArgRep1 arg) + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -603,12 +603,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, -- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | args `lengthIs` arity = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map stgArgRep1 (drop arity args)) + tickySlowCallPat (drop arity args) tickyKnownCallTooFewArgs :: FCode () tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") @@ -610,12 +610,12 @@ tickySlowCall lf_info args = do if isKnownFun lf_info then tickyKnownCallTooFewArgs else tickyUnknownCall - tickySlowCallPat (map stgArgRep1 args) + tickySlowCallPat args -tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform) args + let argReps = map (toArgRep platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,11 +1525,10 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. + -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys - -- Void types are erased when unpacked so we - nv_prim_reps = filter (not . isVoidRep) prim_reps -- And then get the actual size of the unpacked constructor. - rep_size = sum $ map primRepSizeW64_B nv_prim_reps + rep_size = sum $ map primRepSizeW64_B prim_reps in rep_size <= 8 is_sum :: [DataCon] -> Bool ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -160,21 +160,18 @@ dataConRuntimeRepStrictness dc = go repMarks repTys [] where go (mark:marks) (ty:types) out_marks - -- Zero-width argument, mark is irrelevant at runtime. - | -- pprTrace "VoidTy" (ppr ty) $ - (isZeroBitTy ty) - = go marks types out_marks - -- Single rep argument, e.g. Int - -- Keep mark as-is - | [_] <- reps - = go marks types (mark:out_marks) - -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) - -- Make up one non-strict mark per runtime argument. - | otherwise -- TODO: Assert real_reps /= null - = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks) + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) where reps = typePrimRep ty - real_reps = filter (not . isVoidRep) $ reps go [] [] out_marks = reverse out_marks go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) ===================================== m4/fptools_alex.m4 ===================================== @@ -14,7 +14,7 @@ AC_SUBST(AlexCmd,$ALEX) AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, changequote(, )dnl [if test x"$AlexCmd" != x; then - fptools_cv_alex_version=`"$AlexCmd" -v | + fptools_cv_alex_version=`"$AlexCmd" -V | grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; else fptools_cv_alex_version=""; ===================================== testsuite/tests/ghci.debugger/scripts/T24306.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-} +module T24306 where + +import GHC.Exts + +newtype A = MkA (# #) +data T = T Int# A Int# + +x = T 1# (MkA (# #)) 2# ===================================== testsuite/tests/ghci.debugger/scripts/T24306.script ===================================== @@ -0,0 +1,2 @@ +:load T24306 +:force x ===================================== testsuite/tests/ghci.debugger/scripts/T24306.stdout ===================================== @@ -0,0 +1 @@ +x = T 1 (MkA (##)) 2 ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -140,3 +140,4 @@ test('break030', ['break030.script'], ) test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script']) +test('T24306', normal, ghci_script, ['T24306.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9a261eb7855cae677e86e516181beac3b7fb43d...ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b9a261eb7855cae677e86e516181beac3b7fb43d...ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 16:00:38 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 04 Jan 2024 11:00:38 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-metadata-fail] ci: Allow release-hackage-lint to fail Message-ID: <6596d626dad94_3def4470852f8289d9@gitlab.mail> Zubin pushed to branch wip/9.6.4-metadata-fail at Glasgow Haskell Compiler / GHC Commits: b3ddb687 by Zubin Duggal at 2024-01-04T21:30:21+05:30 ci: Allow release-hackage-lint to fail Otherwise it blocks the ghcup metadata pipeline from running. (cherry picked from commit e8960b0af7904f7646915e1ba847e18bfbf3067c) Metric Decrease: MultiLayerModulesTH_Make - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -770,6 +770,10 @@ release-hackage-lint: rules: - if: '$RELEASE_JOB == "yes"' extends: .hackage + # The ghcup metadata pipeline requires all prior jobs to + # pass. The hackage job can easily fail due to API changes + # or similar - so we allow it to fail. + allow_failure: true variables: # No slow-validate bindist on release pipeline EXTRA_HC_OPTS: "-dlint" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3ddb687e3861544d692a9e935b841ee88347ed2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3ddb687e3861544d692a9e935b841ee88347ed2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 20:11:28 2024 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Thu, 04 Jan 2024 15:11:28 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/fprof-overloaded Message-ID: <659710f0125ff_3def44da92b8c344d5@gitlab.mail> Finley McIlwaine pushed new branch wip/fprof-overloaded at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fprof-overloaded You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 20:19:03 2024 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Thu, 04 Jan 2024 15:19:03 -0500 Subject: [Git][ghc/ghc][wip/fprof-overloaded] add -fprof-late-overloaded and -fprof-late-overloaded-calls Message-ID: <659712b795158_3def44e0726743483b@gitlab.mail> Finley McIlwaine pushed to branch wip/fprof-overloaded at Glasgow Haskell Compiler / GHC Commits: 10088922 by Finley McIlwaine at 2024-01-04T12:18:38-08:00 add -fprof-late-overloaded and -fprof-late-overloaded-calls * Refactor late cost centre insertion for extensibility * Add two more late cost centre insertion methods that add SCCs to overloaded top level bindings and call sites with dictionary arguments. * Some tests for the basic functionality of the new insertion mathods - - - - - 26 changed files: - compiler/GHC/Core/LateCC.hs - + compiler/GHC/Core/LateCC/OverloadedCalls.hs - + compiler/GHC/Core/LateCC/TopLevelBinds.hs - + compiler/GHC/Core/LateCC/Types.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/ghc.cabal.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/profiling.rst - testsuite/tests/profiling/should_run/all.T - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout - + testsuite/tests/profiling/should_run/scc001.prof copy.sample Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -1,164 +1,94 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TupleSections #-} - --- | Adds cost-centers after the core piple has run. +-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC - ( addLateCostCentresMG - , addLateCostCentresPgm - , addLateCostCentres -- Might be useful for API users - , Env(..) + ( -- * Inserting cost centres + addLateCostCentres -- Might be useful for API users + + -- * Helpers for defining insertion methods + , getCCFlavour + , insertCC + + -- * Types + , LateCCEnv(..) + , LateCCState(..) + , initLateCCState ) where -import Control.Applicative +import GHC.Prelude + import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict import qualified Data.Set as S -import GHC.Prelude +import GHC.Core +import GHC.Core.LateCC.Types +import GHC.Core.Utils +import GHC.Data.FastString import GHC.Types.CostCentre import GHC.Types.CostCentre.State -import GHC.Types.Name hiding (varName) +import GHC.Types.SrcLoc import GHC.Types.Tickish -import GHC.Unit.Module.ModGuts -import GHC.Types.Var -import GHC.Unit.Types -import GHC.Data.FastString -import GHC.Core -import GHC.Core.Opt.Monad -import GHC.Core.Utils (mkTick) -import GHC.Types.Id -import GHC.Driver.DynFlags - -import GHC.Utils.Logger -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Error (withTiming) -import GHC.Utils.Monad.State.Strict - - -{- Note [Collecting late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Usually cost centres defined by a module are collected -during tidy by collectCostCentres. However with `-fprof-late` -we insert cost centres after inlining. So we keep a list of -all the cost centres we inserted and combine that with the list -of cost centres found during tidy. - -To avoid overhead when using -fprof-inline there is a flag to stop -us from collecting them here when we run this pass before tidy. - -Note [Adding late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is very simple. For every top level binder -`f = rhs` we compile it as if the user had written -`f = {-# SCC f #-} rhs`. - -If we do this after unfoldings for `f` have been created this -doesn't impact core-level optimizations at all. If we do it -before the cost centre will be included in the unfolding and -might inhibit optimizations at the call site. For this reason -we provide flags for both approaches as they have different -tradeoffs. - -We also don't add a cost centre for any binder that is a constructor -worker or wrapper. These will never meaningfully enrich the resulting -profile so we improve efficiency by omitting those. --} - -addLateCostCentresMG :: ModGuts -> CoreM ModGuts -addLateCostCentresMG guts = do - dflags <- getDynFlags - let env :: Env - env = Env - { thisModule = mg_module guts - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = False -- See Note [Collecting late cost centres] - } - let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) - } - return guts' - -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentresPgm dflags logger mod binds = - withTiming logger - (text "LateCC"<+>brackets (ppr mod)) - (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do - let env = Env - { thisModule = mod - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = True -- See Note [Collecting late cost centres] - } - (binds', ccs, cc_state) = addLateCostCentres env binds - when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ - putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds')) - return (binds', ccs, cc_state) - -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentres env binds = - let (binds', state) = runState (mapM (doBind env) binds) initLateCCState - in (binds', lcs_ccs state, lcs_state state) - - -doBind :: Env -> CoreBind -> M CoreBind -doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs -doBind env (Rec bs) = Rec <$> mapM doPair bs +-- | Insert cost centres into the 'CoreProgram' using the provided environment, +-- initial state, and insertion method. +addLateCostCentres + :: LateCCEnv + -- ^ Environment to run the insertion in + -> LateCCState s + -- ^ Initial state to run the insertion with + -> (CoreBind -> LateCCM s CoreBind) + -- ^ Insertion method + -> CoreProgram + -- ^ Bindings to consider + -> (CoreProgram, LateCCState s) +addLateCostCentres env state method binds = + runLateCC env state $ mapM method binds + +-- | Evaluate late cost centre insertion +runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s) +runLateCC env state = (`runState` state) . (`runReaderT` env) + +-- | The empty late cost centre insertion state +initLateCCState :: s -> LateCCState s +initLateCCState s = + LateCCState + { lateCCState_ccState = newCostCentreState + , lateCCState_ccs = mempty + , lateCCState_extra = s + } + +-- | Given the name of a cost centre, get its flavour +getCCFlavour :: FastString -> LateCCM s CCFlavour +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name where - doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr)) - doPair (b,rhs) = (b,) <$> doBndr env b rhs - -doBndr :: Env -> Id -> CoreExpr -> M CoreExpr -doBndr env bndr rhs - -- Cost centres on constructor workers are pretty much useless - -- so we don't emit them if we are looking at the rhs of a constructor - -- binding. - | Just _ <- isDataConId_maybe bndr = pure rhs - | otherwise = doBndr' env bndr rhs - - --- We want to put the cost centre below the lambda as we only care about executions of the RHS. -doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr -doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs -doBndr' env bndr rhs = do - let name = idName bndr - name_loc = nameSrcSpan name - cc_name = getOccFS name - count = countEntries env + getCCIndex' :: FastString -> LateCCM s CostCentreIndex + getCCIndex' name = do + cc_state <- lift $ gets lateCCState_ccState + let (index, cc_state') = getCCIndex name cc_state + lift . modify $ \s -> s { lateCCState_ccState = cc_state'} + return index + +-- | Insert a cost centre with the specified name and source span on the given +-- expression. The inserted cost centre will be appropriately tracked in the +-- late cost centre state. +insertCC + :: FastString + -- ^ Name of the cost centre to insert + -> SrcSpan + -- ^ Source location to associate with the cost centre + -> CoreExpr + -- ^ Expression to wrap in the cost centre + -> LateCCM s CoreExpr +insertCC cc_name cc_loc expr = do cc_flavour <- getCCFlavour cc_name - let cc_mod = thisModule env - bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc - note = ProfNote bndrCC count True - addCC env bndrCC - return $ mkTick note rhs - -data LateCCState = LateCCState - { lcs_state :: !CostCentreState - , lcs_ccs :: S.Set CostCentre - } -type M = State LateCCState - -initLateCCState :: LateCCState -initLateCCState = LateCCState newCostCentreState mempty - -getCCFlavour :: FastString -> M CCFlavour -getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name - -getCCIndex' :: FastString -> M CostCentreIndex -getCCIndex' name = do - state <- get - let (index,cc_state') = getCCIndex name (lcs_state state) - put (state { lcs_state = cc_state'}) - return index - -addCC :: Env -> CostCentre -> M () -addCC !env cc = do - state <- get - when (collectCCs env) $ do - let ccs' = S.insert cc (lcs_ccs state) - put (state { lcs_ccs = ccs'}) - -data Env = Env - { thisModule :: !Module - , countEntries:: !Bool - , collectCCs :: !Bool - } - + env <- ask + let + cc_mod = lateCCEnv_module env + cc = NormalCC cc_flavour cc_name cc_mod cc_loc + note = ProfNote cc (lateCCEnv_countEntries env) True + when (lateCCEnv_collectCCs env) $ do + lift . modify $ \s -> + s { lateCCState_ccs = S.insert cc (lateCCState_ccs s) + } + return $ mkTick note expr ===================================== compiler/GHC/Core/LateCC/OverloadedCalls.hs ===================================== @@ -0,0 +1,176 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Core.LateCC.OverloadedCalls + ( overloadedCallsCC + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified GHC.Data.Strict as Strict + +import GHC.Data.FastString +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Make +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Var +import GHC.Utils.Outputable + +type S = Strict.Maybe SrcSpan + +-- | Insert cost centres on function applications with dictionary arguments. The +-- source locations attached to the cost centres is approximated based on the +-- "closest" source note encountered in the traversal. +overloadedCallsCC :: CoreBind -> LateCCM S CoreBind +overloadedCallsCC = + processBind + where + processBind :: CoreBind -> LateCCM S CoreBind + processBind core_bind = + case core_bind of + NonRec b e -> + NonRec b <$> processExpr e + Rec es -> + Rec <$> mapM (\(b,e) -> (b,) <$> processExpr e) es + + processExpr :: CoreExpr -> LateCCM S CoreExpr + processExpr expr = + case expr of + -- The case we care about: Application + app at App{} -> do + -- Here we have some application like `f v1 ... vN`, where v1 ... vN + -- should be the function's type arguments followed by the value + -- arguments. To determine if the `f` is an overloaded function (i.e. not + -- specialised), we check if any of the arguments v1 ... vN are + -- dictionaries. + let + (f, xs) = collectArgs app + resultTy = applyTypeToArgs empty (exprType f) xs + + -- Recursively process the arguments first for no particular reason + args <- mapM processExpr xs + let app' = mkCoreApps f args + + if + -- Check if any of the arguments are dictionaries + any isDictExpr args + + -- Avoid instrumenting dictionary functions, which may be + -- overloaded if there are superclasses, by checking if the result + -- type of the function is a dictionary type. + && not (isDictTy resultTy) + + -- Avoid instrumenting constraint selectors like eq_sel + && (typeTypeOrConstraint resultTy /= ConstraintLike) + + -- Avoid instrumenting join points + && not (isJoinVarExpr f) + then do + -- Extract a name and source location from the function being + -- applied + let + cc_name :: FastString + cc_name = + fsLit $ maybe "" getOccString (exprName app) + + cc_srcspan <- + fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $ + lift $ gets lateCCState_extra + + insertCC cc_name cc_srcspan app' + else + return app' + + -- For recursive constructors of Expr, we traverse the nested Exprs + Lam b e -> + mkCoreLams [b] <$> processExpr e + Let b e -> + mkCoreLet <$> processBind b <*> processExpr e + Case e b t alts -> + Case + <$> processExpr e + <*> pure b + <*> pure t + <*> mapM processAlt alts + Cast e co -> + mkCast <$> processExpr e <*> pure co + Tick t e -> do + trackSourceNote t $ + mkTick t <$> processExpr e + + -- For non-recursive constructors of Expr, we do nothing + x -> return x + + processAlt :: CoreAlt -> LateCCM S CoreAlt + processAlt (Alt c bs e) = Alt c bs <$> processExpr e + + trackSourceNote :: CoreTickish -> LateCCM S a -> LateCCM S a + trackSourceNote tick act = + case tick of + SourceNote rss _ -> do + -- Prefer source notes from the current file + in_current_file <- + maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$> + asks lateCCEnv_file + if not in_current_file then + act + else do + loc <- lift $ gets lateCCState_extra + lift . modify $ \s -> + s { lateCCState_extra = + Strict.Just $ RealSrcSpan rss mempty + } + x <- act + lift . modify $ \s -> + s { lateCCState_extra = loc + } + return x + _ -> + act + + -- Utility functions + + -- Extract a Name from an expression. If it is an application, attempt to + -- extract a name from the applied function. If the expression is a + -- variable, return the Name of the variable. If the expression is a tick, + -- attempt to extract a Name from the expression held in the tick. Otherwise + -- return Nothing. + exprName :: CoreExpr -> Maybe Name + exprName = + \case + App f _ -> + exprName f + Var f -> + Just (idName f) + Tick _ e -> + exprName e + _ -> + Nothing + + -- Determine whether an expression is a dictionary + isDictExpr :: CoreExpr -> Bool + isDictExpr = + maybe False isDictTy . exprType' + where + exprType' :: CoreExpr -> Maybe Type + exprType' = \case + Type{} -> Nothing + expr -> Just $ exprType expr + + -- Determine whether an expression is a join variable + isJoinVarExpr :: CoreExpr -> Bool + isJoinVarExpr = + \case + Var var -> isJoinId var + _ -> False \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/TopLevelBinds.hs ===================================== @@ -0,0 +1,105 @@ +{-# LANGUAGE TupleSections #-} +module GHC.Core.LateCC.TopLevelBinds where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Opt.Monad +import GHC.Driver.DynFlags +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module.ModGuts + +{- Note [Collecting late cost centres] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usually cost centres defined by a module are collected +during tidy by collectCostCentres. However with `-fprof-late` +we insert cost centres after inlining. So we keep a list of +all the cost centres we inserted and combine that with the list +of cost centres found during tidy. + +To avoid overhead when using -fprof-inline there is a flag to stop +us from collecting them here when we run this pass before tidy. + +Note [Adding late cost centres to top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is very simple. For every top level binder +`f = rhs` we compile it as if the user had written +`f = {-# SCC f #-} rhs`. + +If we do this after unfoldings for `f` have been created this +doesn't impact core-level optimizations at all. If we do it +before the cost centre will be included in the unfolding and +might inhibit optimizations at the call site. For this reason +we provide flags for both approaches as they have different +tradeoffs. + +We also don't add a cost centre for any binder that is a constructor +worker or wrapper. These will never meaningfully enrich the resulting +profile so we improve efficiency by omitting those. + +-} + +-- | Add late cost centres directly to the 'ModGuts'. This is used inside the +-- core pipeline with the -fprof-late-inline flag. It should not be used after +-- tidy, since it does not manually track inserted cost centers. See +-- Note [Collecting late cost centres]. +topLevelBindsCCMG :: ModGuts -> CoreM ModGuts +topLevelBindsCCMG guts = do + dflags <- getDynFlags + let + env = + LateCCEnv + { lateCCEnv_module = mg_module guts + + -- We don't use this for topLevelBindsCC, so Nothing is okay + , lateCCEnv_file = Nothing + + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = False + } + guts' = + guts + { mg_binds = + fst + ( addLateCostCentres + env + (initLateCCState ()) + (topLevelBindsCC (const True)) + (mg_binds guts) + ) + } + return guts' + +-- | Insert cost centres on top level bindings in the module, depending on +-- whether or not they satisfy the given predicate. +topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind +topLevelBindsCC pred core_bind = + case core_bind of + NonRec b rhs -> + NonRec b <$> doBndr b rhs + Rec bs -> + Rec <$> mapM doPair bs + where + doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr)) + doPair (b,rhs) = (b,) <$> doBndr b rhs + + doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr + doBndr bndr rhs + -- Cost centres on constructor workers are pretty much useless + -- so we don't emit them if we are looking at the rhs of a constructor + -- binding. + | Just _ <- isDataConId_maybe bndr = pure rhs + | otherwise = if pred rhs then addCC bndr rhs else pure rhs + + -- We want to put the cost centre below the lambda as we only care about + -- executions of the RHS. + addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs + addCC bndr rhs = do + let name = idName bndr + cc_loc = nameSrcSpan name + cc_name = getOccFS name + insertCC cc_name cc_loc rhs \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/Types.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DerivingStrategies #-} +module GHC.Core.LateCC.Types where + +import GHC.Prelude + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Unit.Types + +-- | Late cost centre insertion environment +data LateCCEnv = LateCCEnv + { lateCCEnv_module :: !Module + -- ^ Current module + , lateCCEnv_file :: Maybe FastString + -- ^ Current file, if we have one + , lateCCEnv_countEntries:: !Bool + -- ^ Whether the inserted cost centers should count entries + , lateCCEnv_collectCCs :: !Bool + -- ^ Whether to collect the cost centres we insert. See + -- Note [Collecting late cost centres] + } + +-- | Late cost centre insertion state, indexed by some extra state type that an +-- insertion method may require. +data LateCCState s = LateCCState + { lateCCState_ccs :: !(S.Set CostCentre) + -- ^ Cost centres that have been inserted + , lateCCState_ccState :: !CostCentreState + -- ^ Per-module state tracking for cost centre indices + , lateCCState_extra :: !s + } + +-- | Late cost centre insertion monad +type LateCCM s = ReaderT LateCCEnv (State (LateCCState s)) ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -43,7 +43,7 @@ import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) -import GHC.Core.LateCC (addLateCostCentresMG) +import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -515,7 +515,7 @@ doCorePass pass guts = do addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} - addLateCostCentresMG guts + topLevelBindsCCMG guts CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -335,6 +335,8 @@ data GeneralFlag | Opt_ProfCountEntries | Opt_ProfLateInlineCcs | Opt_ProfLateCcs + | Opt_ProfLateOverloadedCcs + | Opt_ProfLateoverloadedCallsCCs | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations -- misc opts ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -175,7 +175,6 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) import GHC.Core import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) -import GHC.Core.Type ( Type, Kind ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike import GHC.Core.Opt.Pipeline @@ -185,7 +184,9 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Rules import GHC.Core.Stats -import GHC.Core.LateCC (addLateCostCentresPgm) +import GHC.Core.LateCC +import GHC.Core.LateCC.TopLevelBinds +import GHC.Core.LateCC.OverloadedCalls import GHC.CoreToStg.Prep @@ -197,6 +198,7 @@ import GHC.Parser.Lexer as Lexer import GHC.Tc.Module import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax @@ -266,6 +268,7 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict import qualified GHC.SysTools import GHC.SysTools (initSysTools) @@ -297,7 +300,6 @@ import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) -import GHC.Types.CostCentre.State (newCostCentreState) {- ********************************************************************** @@ -1791,22 +1793,70 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------- - -- Insert late cost centres if enabled. + -- Insert late cost centres on top level bindings if enabled. -- If `-fprof-late-inline` is enabled we can skip this, as it will have added -- a superset of cost centres we would add here already. - (late_cc_binds, late_local_ccs, cc_state) <- - if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then - withTiming - logger - (text "LateCCs"<+>brackets (ppr this_mod)) - (const ()) - $ {-# SCC lateCC #-} do - (binds, late_ccs, cc_state) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs ), cc_state) - else - return (core_binds, local_ccs, newCostCentreState) + -- If `-fprof-late-overloaded` is enabled, only add CCs to bindings for + -- overloaded functions. + let + topLevelCCPred :: CoreExpr -> Bool + topLevelCCPred = + if gopt Opt_ProfLateOverloadedCcs dflags then + isOverloadedTy . exprType + else + const True + + doLateTopLevelCcs :: Bool + doLateTopLevelCcs = + (gopt Opt_ProfLateCcs dflags || gopt Opt_ProfLateOverloadedCcs dflags) && not (gopt Opt_ProfLateInlineCcs dflags) + + lateCCEnv :: LateCCEnv + lateCCEnv = + LateCCEnv + { lateCCEnv_module = this_mod + , lateCCEnv_file = fsLit <$> ml_hs_file location + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = True + } + + (top_level_cc_binds, top_level_late_cc_state) <- + if doLateTopLevelCcs then do + withTiming + logger + (text "LateTopLevelCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateTopLevelCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (initLateCCState ()) + (topLevelBindsCC topLevelCCPred) + core_binds + else + return (core_binds, initLateCCState ()) + + (late_cc_binds, late_cc_state) <- + if gopt Opt_ProfLateoverloadedCallsCCs dflags then + withTiming + logger + (text "LateOverloadedCallsCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateoverloadedCallsCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (top_level_late_cc_state { lateCCState_extra = Strict.Nothing }) + overloadedCallsCC + top_level_cc_binds + else + return + ( top_level_cc_binds + , top_level_late_cc_state { lateCCState_extra = Strict.Nothing } + ) + + when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ + putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds)) ------------------- -- Run late plugins @@ -1820,7 +1870,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_hpc_info = hpc_info, cg_spt_entries = spt_entries, cg_binds = late_binds, - cg_ccs = late_local_ccs' + cg_ccs = late_local_ccs } , _ ) <- @@ -1833,9 +1883,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do (($ hsc_env) . latePlugin) ( cgguts { cg_binds = late_cc_binds - , cg_ccs = late_local_ccs + , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs } - , cc_state + , lateCCState_ccState late_cc_state ) let @@ -1876,7 +1926,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let (stg_binds,_stg_deps) = unzip stg_binds_with_deps let cost_centre_info = - (late_local_ccs' ++ caf_ccs, caf_cc_stacks) + (late_local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags prof_init | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2431,6 +2431,8 @@ fFlagsDeps = [ flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "prof-late" Opt_ProfLateCcs, + flagSpec "prof-late-overloaded" Opt_ProfLateOverloadedCcs, + flagSpec "prof-late-overloaded-calls" Opt_ProfLateoverloadedCallsCCs, flagSpec "prof-manual" Opt_ProfManualCcs, flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, flagSpec "regs-graph" Opt_RegsGraph, @@ -3748,6 +3750,10 @@ needSourceNotes :: DynFlags -> Bool needSourceNotes dflags = debugLevel dflags > 0 || gopt Opt_InfoTableMap dflags + -- Source ticks are used to approximate the location of + -- overloaded call cost centers + || gopt Opt_ProfLateoverloadedCallsCCs dflags + -- ----------------------------------------------------------------------------- -- Linker/compiler information ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -1883,7 +1883,7 @@ isRhoExpTy (Infer {}) = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods +-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af ===================================== compiler/ghc.cabal.in ===================================== @@ -338,6 +338,9 @@ Library GHC.Core.Lint GHC.Core.Lint.Interactive GHC.Core.LateCC + GHC.Core.LateCC.Types + GHC.Core.LateCC.TopLevelBinds + GHC.Core.LateCC.OverloadedCalls GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -129,6 +129,15 @@ Compiler - Late plugins have been added. These are plugins which can access and/or modify the core of a module after optimization and after interface creation. See :ghc-ticket:`24254`. +- The :ghc-flag:`-fprof-late-overloaded` flag has been introduced. It causes + cost centres to be added to *overloaded* top level bindings, unlike + :ghc-flag:`-fprof-late` which adds cost centres to all top level bindings. + +- The :ghc-flag:`-fprof-late-overloaded-calls` flag has been introduced. It + causes cost centres to be inserted at call sites including instance dictionary + arguments. This may be preferred over :ghc-flag:`-fprof-late-overloaded` since + it may reveal whether imported functions are called overloaded. + GHCi ~~~~ ===================================== docs/users_guide/profiling.rst ===================================== @@ -518,6 +518,42 @@ of your profiled program will be different to that of the unprofiled one. You can try this mode if :ghc-flag:`-fprof-late` results in a profile that's too hard to interpret. +.. ghc-flag:: -fprof-late-overloaded + :shortdesc: Auto-add ``SCC``\\ s to all top level overloaded bindings *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all *overloaded* top level bindings + late in the compilation pipeline after the optimizer has run and unfoldings + have been created. This means these cost centres will not interfere with + core-level optimizations and the resulting profile will be closer to the + performance profile of an optimized non-profiled executable. + + This flag can help determine which top level bindings encountered during a + program's execution are still overloaded after inlining and specialization. + +.. ghc-flag:: -fprof-late-overloaded-calls + :shortdesc: Auto-add ``SCC``\\ s to all call sites that include dictionary arguments *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded-calls + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all call sites that include + dictionary arguments late in the compilation pipeline after the optimizer + has run and unfoldings have been created. This means these cost centres will + not interfere with core-level optimizations and the resulting profile will + be closer to the performance profile of an optimized non-profiled + executable. + + This flag is potentially more useful than :ghc-flag:`-fprof-late-overloaded` + since it will add ``SCC`` annotations to call sites of imported functions + that are overloaded. + .. ghc-flag:: -fprof-cafs :shortdesc: Auto-add ``SCC``\\ s to all CAFs :type: dynamic ===================================== testsuite/tests/profiling/should_run/all.T ===================================== @@ -196,3 +196,28 @@ test('ignore_scc', [], compile_and_run, ['-fno-prof-manual']) test('T21446', [], makefile_test, ['T21446']) + + +test('scc-prof-overloaded001', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded002', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls001', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded-calls'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls002', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded-calls'] # See Note [consistent stacks] +) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample ===================================== @@ -0,0 +1,26 @@ + Thu Jan 4 11:49 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,320 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded-calls001.hs:24:1-31 256 1 0.0 0.3 0.0 0.8 + f Main scc-prof-overloaded-calls001.hs:18:1-18 257 1 0.0 0.6 0.0 0.6 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample ===================================== @@ -0,0 +1,30 @@ + Thu Jan 4 11:57 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls002 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 54,312 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 29.6 +CAF GHC.IO.Handle.FD 0.0 64.0 +CAF GHC.IO.Encoding 0.0 4.5 +CAF GHC.Conc.Signal 0.0 1.2 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 29.6 0.0 100.0 + f Main scc-prof-overloaded-calls002.hs:52:1-25 262 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:48:1-25 261 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:44:1-25 260 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:40:1-25 259 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:36:1-25 258 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:32:1-25 257 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:28:1-25 256 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 238 0 0.0 1.2 0.0 1.2 + CAF GHC.IO.Encoding 219 0 0.0 4.5 0.0 4.5 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 64.0 0.0 64.0 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample ===================================== @@ -0,0 +1,25 @@ + Thu Jan 4 11:26 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,304 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded001.hs:18:1-6 256 1 0.0 0.8 0.0 0.8 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample ===================================== @@ -0,0 +1,23 @@ + Thu Jan 4 11:55 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded002 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 56,472 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 32.7 +CAF GHC.IO.Handle.FD 0.0 61.5 +CAF GHC.IO.Encoding 0.0 4.3 +CAF GHC.Conc.Signal 0.0 1.1 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 32.7 0.0 100.0 + CAF GHC.Conc.Signal 238 0 0.0 1.1 0.0 1.1 + CAF GHC.IO.Encoding 219 0 0.0 4.3 0.0 4.3 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 61.5 0.0 61.5 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc001.prof copy.sample ===================================== @@ -0,0 +1,33 @@ + Wed Mar 29 06:17 2017 Time and Allocation Profiling Report (Final) + + scc001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 50,856 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 1.6 +CAF GHC.IO.Handle.FD 0.0 68.3 +CAF GHC.IO.Encoding 0.0 5.4 +CAF GHC.Conc.Signal 0.0 1.3 +main Main scc001.hs:(5,1)-(7,23) 0.0 22.2 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 111 0 0.0 1.6 0.0 100.0 + CAF Main 221 0 0.0 0.0 0.0 0.6 + (...) Main scc001.hs:16:1-16 227 1 0.0 0.0 0.0 0.0 + main Main scc001.hs:(5,1)-(7,23) 222 1 0.0 0.5 0.0 0.5 + h Main scc001.hs:16:1-16 226 1 0.0 0.0 0.0 0.0 + f Main scc001.hs:10:1-7 224 1 0.0 0.0 0.0 0.0 + g Main scc001.hs:13:1-7 225 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 216 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 206 0 0.0 5.4 0.0 5.4 + CAF GHC.IO.Encoding.Iconv 204 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 196 0 0.0 68.3 0.0 68.3 + CAF GHC.IO.Handle.Text 194 0 0.0 0.2 0.0 0.2 + CAF GHC.Show 179 0 0.0 0.6 0.0 0.6 + main Main scc001.hs:(5,1)-(7,23) 223 0 0.0 21.7 0.0 21.7 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1008892247c6a962a454212edfeee27b91756798 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1008892247c6a962a454212edfeee27b91756798 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 20:19:59 2024 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Thu, 04 Jan 2024 15:19:59 -0500 Subject: [Git][ghc/ghc][wip/fprof-overloaded] add -fprof-late-overloaded and -fprof-late-overloaded-calls Message-ID: <659712ef945bb_3def44e0e561035032@gitlab.mail> Finley McIlwaine pushed to branch wip/fprof-overloaded at Glasgow Haskell Compiler / GHC Commits: 96e96288 by Finley McIlwaine at 2024-01-04T12:19:36-08:00 add -fprof-late-overloaded and -fprof-late-overloaded-calls * Refactor late cost centre insertion for extensibility * Add two more late cost centre insertion methods that add SCCs to overloaded top level bindings and call sites with dictionary arguments. * Some tests for the basic functionality of the new insertion methods - - - - - 26 changed files: - compiler/GHC/Core/LateCC.hs - + compiler/GHC/Core/LateCC/OverloadedCalls.hs - + compiler/GHC/Core/LateCC/TopLevelBinds.hs - + compiler/GHC/Core/LateCC/Types.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/ghc.cabal.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/profiling.rst - testsuite/tests/profiling/should_run/all.T - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout - + testsuite/tests/profiling/should_run/scc001.prof copy.sample Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -1,164 +1,94 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TupleSections #-} - --- | Adds cost-centers after the core piple has run. +-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC - ( addLateCostCentresMG - , addLateCostCentresPgm - , addLateCostCentres -- Might be useful for API users - , Env(..) + ( -- * Inserting cost centres + addLateCostCentres -- Might be useful for API users + + -- * Helpers for defining insertion methods + , getCCFlavour + , insertCC + + -- * Types + , LateCCEnv(..) + , LateCCState(..) + , initLateCCState ) where -import Control.Applicative +import GHC.Prelude + import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict import qualified Data.Set as S -import GHC.Prelude +import GHC.Core +import GHC.Core.LateCC.Types +import GHC.Core.Utils +import GHC.Data.FastString import GHC.Types.CostCentre import GHC.Types.CostCentre.State -import GHC.Types.Name hiding (varName) +import GHC.Types.SrcLoc import GHC.Types.Tickish -import GHC.Unit.Module.ModGuts -import GHC.Types.Var -import GHC.Unit.Types -import GHC.Data.FastString -import GHC.Core -import GHC.Core.Opt.Monad -import GHC.Core.Utils (mkTick) -import GHC.Types.Id -import GHC.Driver.DynFlags - -import GHC.Utils.Logger -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Error (withTiming) -import GHC.Utils.Monad.State.Strict - - -{- Note [Collecting late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Usually cost centres defined by a module are collected -during tidy by collectCostCentres. However with `-fprof-late` -we insert cost centres after inlining. So we keep a list of -all the cost centres we inserted and combine that with the list -of cost centres found during tidy. - -To avoid overhead when using -fprof-inline there is a flag to stop -us from collecting them here when we run this pass before tidy. - -Note [Adding late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is very simple. For every top level binder -`f = rhs` we compile it as if the user had written -`f = {-# SCC f #-} rhs`. - -If we do this after unfoldings for `f` have been created this -doesn't impact core-level optimizations at all. If we do it -before the cost centre will be included in the unfolding and -might inhibit optimizations at the call site. For this reason -we provide flags for both approaches as they have different -tradeoffs. - -We also don't add a cost centre for any binder that is a constructor -worker or wrapper. These will never meaningfully enrich the resulting -profile so we improve efficiency by omitting those. --} - -addLateCostCentresMG :: ModGuts -> CoreM ModGuts -addLateCostCentresMG guts = do - dflags <- getDynFlags - let env :: Env - env = Env - { thisModule = mg_module guts - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = False -- See Note [Collecting late cost centres] - } - let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) - } - return guts' - -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentresPgm dflags logger mod binds = - withTiming logger - (text "LateCC"<+>brackets (ppr mod)) - (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do - let env = Env - { thisModule = mod - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = True -- See Note [Collecting late cost centres] - } - (binds', ccs, cc_state) = addLateCostCentres env binds - when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ - putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds')) - return (binds', ccs, cc_state) - -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentres env binds = - let (binds', state) = runState (mapM (doBind env) binds) initLateCCState - in (binds', lcs_ccs state, lcs_state state) - - -doBind :: Env -> CoreBind -> M CoreBind -doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs -doBind env (Rec bs) = Rec <$> mapM doPair bs +-- | Insert cost centres into the 'CoreProgram' using the provided environment, +-- initial state, and insertion method. +addLateCostCentres + :: LateCCEnv + -- ^ Environment to run the insertion in + -> LateCCState s + -- ^ Initial state to run the insertion with + -> (CoreBind -> LateCCM s CoreBind) + -- ^ Insertion method + -> CoreProgram + -- ^ Bindings to consider + -> (CoreProgram, LateCCState s) +addLateCostCentres env state method binds = + runLateCC env state $ mapM method binds + +-- | Evaluate late cost centre insertion +runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s) +runLateCC env state = (`runState` state) . (`runReaderT` env) + +-- | The empty late cost centre insertion state +initLateCCState :: s -> LateCCState s +initLateCCState s = + LateCCState + { lateCCState_ccState = newCostCentreState + , lateCCState_ccs = mempty + , lateCCState_extra = s + } + +-- | Given the name of a cost centre, get its flavour +getCCFlavour :: FastString -> LateCCM s CCFlavour +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name where - doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr)) - doPair (b,rhs) = (b,) <$> doBndr env b rhs - -doBndr :: Env -> Id -> CoreExpr -> M CoreExpr -doBndr env bndr rhs - -- Cost centres on constructor workers are pretty much useless - -- so we don't emit them if we are looking at the rhs of a constructor - -- binding. - | Just _ <- isDataConId_maybe bndr = pure rhs - | otherwise = doBndr' env bndr rhs - - --- We want to put the cost centre below the lambda as we only care about executions of the RHS. -doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr -doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs -doBndr' env bndr rhs = do - let name = idName bndr - name_loc = nameSrcSpan name - cc_name = getOccFS name - count = countEntries env + getCCIndex' :: FastString -> LateCCM s CostCentreIndex + getCCIndex' name = do + cc_state <- lift $ gets lateCCState_ccState + let (index, cc_state') = getCCIndex name cc_state + lift . modify $ \s -> s { lateCCState_ccState = cc_state'} + return index + +-- | Insert a cost centre with the specified name and source span on the given +-- expression. The inserted cost centre will be appropriately tracked in the +-- late cost centre state. +insertCC + :: FastString + -- ^ Name of the cost centre to insert + -> SrcSpan + -- ^ Source location to associate with the cost centre + -> CoreExpr + -- ^ Expression to wrap in the cost centre + -> LateCCM s CoreExpr +insertCC cc_name cc_loc expr = do cc_flavour <- getCCFlavour cc_name - let cc_mod = thisModule env - bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc - note = ProfNote bndrCC count True - addCC env bndrCC - return $ mkTick note rhs - -data LateCCState = LateCCState - { lcs_state :: !CostCentreState - , lcs_ccs :: S.Set CostCentre - } -type M = State LateCCState - -initLateCCState :: LateCCState -initLateCCState = LateCCState newCostCentreState mempty - -getCCFlavour :: FastString -> M CCFlavour -getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name - -getCCIndex' :: FastString -> M CostCentreIndex -getCCIndex' name = do - state <- get - let (index,cc_state') = getCCIndex name (lcs_state state) - put (state { lcs_state = cc_state'}) - return index - -addCC :: Env -> CostCentre -> M () -addCC !env cc = do - state <- get - when (collectCCs env) $ do - let ccs' = S.insert cc (lcs_ccs state) - put (state { lcs_ccs = ccs'}) - -data Env = Env - { thisModule :: !Module - , countEntries:: !Bool - , collectCCs :: !Bool - } - + env <- ask + let + cc_mod = lateCCEnv_module env + cc = NormalCC cc_flavour cc_name cc_mod cc_loc + note = ProfNote cc (lateCCEnv_countEntries env) True + when (lateCCEnv_collectCCs env) $ do + lift . modify $ \s -> + s { lateCCState_ccs = S.insert cc (lateCCState_ccs s) + } + return $ mkTick note expr ===================================== compiler/GHC/Core/LateCC/OverloadedCalls.hs ===================================== @@ -0,0 +1,176 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Core.LateCC.OverloadedCalls + ( overloadedCallsCC + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified GHC.Data.Strict as Strict + +import GHC.Data.FastString +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Make +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Var +import GHC.Utils.Outputable + +type S = Strict.Maybe SrcSpan + +-- | Insert cost centres on function applications with dictionary arguments. The +-- source locations attached to the cost centres is approximated based on the +-- "closest" source note encountered in the traversal. +overloadedCallsCC :: CoreBind -> LateCCM S CoreBind +overloadedCallsCC = + processBind + where + processBind :: CoreBind -> LateCCM S CoreBind + processBind core_bind = + case core_bind of + NonRec b e -> + NonRec b <$> processExpr e + Rec es -> + Rec <$> mapM (\(b,e) -> (b,) <$> processExpr e) es + + processExpr :: CoreExpr -> LateCCM S CoreExpr + processExpr expr = + case expr of + -- The case we care about: Application + app at App{} -> do + -- Here we have some application like `f v1 ... vN`, where v1 ... vN + -- should be the function's type arguments followed by the value + -- arguments. To determine if the `f` is an overloaded function (i.e. not + -- specialised), we check if any of the arguments v1 ... vN are + -- dictionaries. + let + (f, xs) = collectArgs app + resultTy = applyTypeToArgs empty (exprType f) xs + + -- Recursively process the arguments first for no particular reason + args <- mapM processExpr xs + let app' = mkCoreApps f args + + if + -- Check if any of the arguments are dictionaries + any isDictExpr args + + -- Avoid instrumenting dictionary functions, which may be + -- overloaded if there are superclasses, by checking if the result + -- type of the function is a dictionary type. + && not (isDictTy resultTy) + + -- Avoid instrumenting constraint selectors like eq_sel + && (typeTypeOrConstraint resultTy /= ConstraintLike) + + -- Avoid instrumenting join points + && not (isJoinVarExpr f) + then do + -- Extract a name and source location from the function being + -- applied + let + cc_name :: FastString + cc_name = + fsLit $ maybe "" getOccString (exprName app) + + cc_srcspan <- + fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $ + lift $ gets lateCCState_extra + + insertCC cc_name cc_srcspan app' + else + return app' + + -- For recursive constructors of Expr, we traverse the nested Exprs + Lam b e -> + mkCoreLams [b] <$> processExpr e + Let b e -> + mkCoreLet <$> processBind b <*> processExpr e + Case e b t alts -> + Case + <$> processExpr e + <*> pure b + <*> pure t + <*> mapM processAlt alts + Cast e co -> + mkCast <$> processExpr e <*> pure co + Tick t e -> do + trackSourceNote t $ + mkTick t <$> processExpr e + + -- For non-recursive constructors of Expr, we do nothing + x -> return x + + processAlt :: CoreAlt -> LateCCM S CoreAlt + processAlt (Alt c bs e) = Alt c bs <$> processExpr e + + trackSourceNote :: CoreTickish -> LateCCM S a -> LateCCM S a + trackSourceNote tick act = + case tick of + SourceNote rss _ -> do + -- Prefer source notes from the current file + in_current_file <- + maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$> + asks lateCCEnv_file + if not in_current_file then + act + else do + loc <- lift $ gets lateCCState_extra + lift . modify $ \s -> + s { lateCCState_extra = + Strict.Just $ RealSrcSpan rss mempty + } + x <- act + lift . modify $ \s -> + s { lateCCState_extra = loc + } + return x + _ -> + act + + -- Utility functions + + -- Extract a Name from an expression. If it is an application, attempt to + -- extract a name from the applied function. If the expression is a + -- variable, return the Name of the variable. If the expression is a tick, + -- attempt to extract a Name from the expression held in the tick. Otherwise + -- return Nothing. + exprName :: CoreExpr -> Maybe Name + exprName = + \case + App f _ -> + exprName f + Var f -> + Just (idName f) + Tick _ e -> + exprName e + _ -> + Nothing + + -- Determine whether an expression is a dictionary + isDictExpr :: CoreExpr -> Bool + isDictExpr = + maybe False isDictTy . exprType' + where + exprType' :: CoreExpr -> Maybe Type + exprType' = \case + Type{} -> Nothing + expr -> Just $ exprType expr + + -- Determine whether an expression is a join variable + isJoinVarExpr :: CoreExpr -> Bool + isJoinVarExpr = + \case + Var var -> isJoinId var + _ -> False \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/TopLevelBinds.hs ===================================== @@ -0,0 +1,105 @@ +{-# LANGUAGE TupleSections #-} +module GHC.Core.LateCC.TopLevelBinds where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Opt.Monad +import GHC.Driver.DynFlags +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module.ModGuts + +{- Note [Collecting late cost centres] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usually cost centres defined by a module are collected +during tidy by collectCostCentres. However with `-fprof-late` +we insert cost centres after inlining. So we keep a list of +all the cost centres we inserted and combine that with the list +of cost centres found during tidy. + +To avoid overhead when using -fprof-inline there is a flag to stop +us from collecting them here when we run this pass before tidy. + +Note [Adding late cost centres to top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is very simple. For every top level binder +`f = rhs` we compile it as if the user had written +`f = {-# SCC f #-} rhs`. + +If we do this after unfoldings for `f` have been created this +doesn't impact core-level optimizations at all. If we do it +before the cost centre will be included in the unfolding and +might inhibit optimizations at the call site. For this reason +we provide flags for both approaches as they have different +tradeoffs. + +We also don't add a cost centre for any binder that is a constructor +worker or wrapper. These will never meaningfully enrich the resulting +profile so we improve efficiency by omitting those. + +-} + +-- | Add late cost centres directly to the 'ModGuts'. This is used inside the +-- core pipeline with the -fprof-late-inline flag. It should not be used after +-- tidy, since it does not manually track inserted cost centers. See +-- Note [Collecting late cost centres]. +topLevelBindsCCMG :: ModGuts -> CoreM ModGuts +topLevelBindsCCMG guts = do + dflags <- getDynFlags + let + env = + LateCCEnv + { lateCCEnv_module = mg_module guts + + -- We don't use this for topLevelBindsCC, so Nothing is okay + , lateCCEnv_file = Nothing + + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = False + } + guts' = + guts + { mg_binds = + fst + ( addLateCostCentres + env + (initLateCCState ()) + (topLevelBindsCC (const True)) + (mg_binds guts) + ) + } + return guts' + +-- | Insert cost centres on top level bindings in the module, depending on +-- whether or not they satisfy the given predicate. +topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind +topLevelBindsCC pred core_bind = + case core_bind of + NonRec b rhs -> + NonRec b <$> doBndr b rhs + Rec bs -> + Rec <$> mapM doPair bs + where + doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr)) + doPair (b,rhs) = (b,) <$> doBndr b rhs + + doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr + doBndr bndr rhs + -- Cost centres on constructor workers are pretty much useless + -- so we don't emit them if we are looking at the rhs of a constructor + -- binding. + | Just _ <- isDataConId_maybe bndr = pure rhs + | otherwise = if pred rhs then addCC bndr rhs else pure rhs + + -- We want to put the cost centre below the lambda as we only care about + -- executions of the RHS. + addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs + addCC bndr rhs = do + let name = idName bndr + cc_loc = nameSrcSpan name + cc_name = getOccFS name + insertCC cc_name cc_loc rhs \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/Types.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DerivingStrategies #-} +module GHC.Core.LateCC.Types where + +import GHC.Prelude + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Unit.Types + +-- | Late cost centre insertion environment +data LateCCEnv = LateCCEnv + { lateCCEnv_module :: !Module + -- ^ Current module + , lateCCEnv_file :: Maybe FastString + -- ^ Current file, if we have one + , lateCCEnv_countEntries:: !Bool + -- ^ Whether the inserted cost centers should count entries + , lateCCEnv_collectCCs :: !Bool + -- ^ Whether to collect the cost centres we insert. See + -- Note [Collecting late cost centres] + } + +-- | Late cost centre insertion state, indexed by some extra state type that an +-- insertion method may require. +data LateCCState s = LateCCState + { lateCCState_ccs :: !(S.Set CostCentre) + -- ^ Cost centres that have been inserted + , lateCCState_ccState :: !CostCentreState + -- ^ Per-module state tracking for cost centre indices + , lateCCState_extra :: !s + } + +-- | Late cost centre insertion monad +type LateCCM s = ReaderT LateCCEnv (State (LateCCState s)) ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -43,7 +43,7 @@ import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) -import GHC.Core.LateCC (addLateCostCentresMG) +import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -515,7 +515,7 @@ doCorePass pass guts = do addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} - addLateCostCentresMG guts + topLevelBindsCCMG guts CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -335,6 +335,8 @@ data GeneralFlag | Opt_ProfCountEntries | Opt_ProfLateInlineCcs | Opt_ProfLateCcs + | Opt_ProfLateOverloadedCcs + | Opt_ProfLateoverloadedCallsCCs | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations -- misc opts ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -175,7 +175,6 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) import GHC.Core import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) -import GHC.Core.Type ( Type, Kind ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike import GHC.Core.Opt.Pipeline @@ -185,7 +184,9 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Rules import GHC.Core.Stats -import GHC.Core.LateCC (addLateCostCentresPgm) +import GHC.Core.LateCC +import GHC.Core.LateCC.TopLevelBinds +import GHC.Core.LateCC.OverloadedCalls import GHC.CoreToStg.Prep @@ -197,6 +198,7 @@ import GHC.Parser.Lexer as Lexer import GHC.Tc.Module import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax @@ -266,6 +268,7 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict import qualified GHC.SysTools import GHC.SysTools (initSysTools) @@ -297,7 +300,6 @@ import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) -import GHC.Types.CostCentre.State (newCostCentreState) {- ********************************************************************** @@ -1791,22 +1793,70 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------- - -- Insert late cost centres if enabled. + -- Insert late cost centres on top level bindings if enabled. -- If `-fprof-late-inline` is enabled we can skip this, as it will have added -- a superset of cost centres we would add here already. - (late_cc_binds, late_local_ccs, cc_state) <- - if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then - withTiming - logger - (text "LateCCs"<+>brackets (ppr this_mod)) - (const ()) - $ {-# SCC lateCC #-} do - (binds, late_ccs, cc_state) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs ), cc_state) - else - return (core_binds, local_ccs, newCostCentreState) + -- If `-fprof-late-overloaded` is enabled, only add CCs to bindings for + -- overloaded functions. + let + topLevelCCPred :: CoreExpr -> Bool + topLevelCCPred = + if gopt Opt_ProfLateOverloadedCcs dflags then + isOverloadedTy . exprType + else + const True + + doLateTopLevelCcs :: Bool + doLateTopLevelCcs = + (gopt Opt_ProfLateCcs dflags || gopt Opt_ProfLateOverloadedCcs dflags) && not (gopt Opt_ProfLateInlineCcs dflags) + + lateCCEnv :: LateCCEnv + lateCCEnv = + LateCCEnv + { lateCCEnv_module = this_mod + , lateCCEnv_file = fsLit <$> ml_hs_file location + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = True + } + + (top_level_cc_binds, top_level_late_cc_state) <- + if doLateTopLevelCcs then do + withTiming + logger + (text "LateTopLevelCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateTopLevelCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (initLateCCState ()) + (topLevelBindsCC topLevelCCPred) + core_binds + else + return (core_binds, initLateCCState ()) + + (late_cc_binds, late_cc_state) <- + if gopt Opt_ProfLateoverloadedCallsCCs dflags then + withTiming + logger + (text "LateOverloadedCallsCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateoverloadedCallsCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (top_level_late_cc_state { lateCCState_extra = Strict.Nothing }) + overloadedCallsCC + top_level_cc_binds + else + return + ( top_level_cc_binds + , top_level_late_cc_state { lateCCState_extra = Strict.Nothing } + ) + + when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ + putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds)) ------------------- -- Run late plugins @@ -1820,7 +1870,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_hpc_info = hpc_info, cg_spt_entries = spt_entries, cg_binds = late_binds, - cg_ccs = late_local_ccs' + cg_ccs = late_local_ccs } , _ ) <- @@ -1833,9 +1883,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do (($ hsc_env) . latePlugin) ( cgguts { cg_binds = late_cc_binds - , cg_ccs = late_local_ccs + , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs } - , cc_state + , lateCCState_ccState late_cc_state ) let @@ -1876,7 +1926,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let (stg_binds,_stg_deps) = unzip stg_binds_with_deps let cost_centre_info = - (late_local_ccs' ++ caf_ccs, caf_cc_stacks) + (late_local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags prof_init | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2431,6 +2431,8 @@ fFlagsDeps = [ flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "prof-late" Opt_ProfLateCcs, + flagSpec "prof-late-overloaded" Opt_ProfLateOverloadedCcs, + flagSpec "prof-late-overloaded-calls" Opt_ProfLateoverloadedCallsCCs, flagSpec "prof-manual" Opt_ProfManualCcs, flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, flagSpec "regs-graph" Opt_RegsGraph, @@ -3748,6 +3750,10 @@ needSourceNotes :: DynFlags -> Bool needSourceNotes dflags = debugLevel dflags > 0 || gopt Opt_InfoTableMap dflags + -- Source ticks are used to approximate the location of + -- overloaded call cost centers + || gopt Opt_ProfLateoverloadedCallsCCs dflags + -- ----------------------------------------------------------------------------- -- Linker/compiler information ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -1883,7 +1883,7 @@ isRhoExpTy (Infer {}) = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods +-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af ===================================== compiler/ghc.cabal.in ===================================== @@ -338,6 +338,9 @@ Library GHC.Core.Lint GHC.Core.Lint.Interactive GHC.Core.LateCC + GHC.Core.LateCC.Types + GHC.Core.LateCC.TopLevelBinds + GHC.Core.LateCC.OverloadedCalls GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -129,6 +129,15 @@ Compiler - Late plugins have been added. These are plugins which can access and/or modify the core of a module after optimization and after interface creation. See :ghc-ticket:`24254`. +- The :ghc-flag:`-fprof-late-overloaded` flag has been introduced. It causes + cost centres to be added to *overloaded* top level bindings, unlike + :ghc-flag:`-fprof-late` which adds cost centres to all top level bindings. + +- The :ghc-flag:`-fprof-late-overloaded-calls` flag has been introduced. It + causes cost centres to be inserted at call sites including instance dictionary + arguments. This may be preferred over :ghc-flag:`-fprof-late-overloaded` since + it may reveal whether imported functions are called overloaded. + GHCi ~~~~ ===================================== docs/users_guide/profiling.rst ===================================== @@ -518,6 +518,42 @@ of your profiled program will be different to that of the unprofiled one. You can try this mode if :ghc-flag:`-fprof-late` results in a profile that's too hard to interpret. +.. ghc-flag:: -fprof-late-overloaded + :shortdesc: Auto-add ``SCC``\\ s to all top level overloaded bindings *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all *overloaded* top level bindings + late in the compilation pipeline after the optimizer has run and unfoldings + have been created. This means these cost centres will not interfere with + core-level optimizations and the resulting profile will be closer to the + performance profile of an optimized non-profiled executable. + + This flag can help determine which top level bindings encountered during a + program's execution are still overloaded after inlining and specialization. + +.. ghc-flag:: -fprof-late-overloaded-calls + :shortdesc: Auto-add ``SCC``\\ s to all call sites that include dictionary arguments *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded-calls + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all call sites that include + dictionary arguments late in the compilation pipeline after the optimizer + has run and unfoldings have been created. This means these cost centres will + not interfere with core-level optimizations and the resulting profile will + be closer to the performance profile of an optimized non-profiled + executable. + + This flag is potentially more useful than :ghc-flag:`-fprof-late-overloaded` + since it will add ``SCC`` annotations to call sites of imported functions + that are overloaded. + .. ghc-flag:: -fprof-cafs :shortdesc: Auto-add ``SCC``\\ s to all CAFs :type: dynamic ===================================== testsuite/tests/profiling/should_run/all.T ===================================== @@ -196,3 +196,28 @@ test('ignore_scc', [], compile_and_run, ['-fno-prof-manual']) test('T21446', [], makefile_test, ['T21446']) + + +test('scc-prof-overloaded001', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded002', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls001', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded-calls'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls002', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded-calls'] # See Note [consistent stacks] +) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample ===================================== @@ -0,0 +1,26 @@ + Thu Jan 4 11:49 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,320 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded-calls001.hs:24:1-31 256 1 0.0 0.3 0.0 0.8 + f Main scc-prof-overloaded-calls001.hs:18:1-18 257 1 0.0 0.6 0.0 0.6 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample ===================================== @@ -0,0 +1,30 @@ + Thu Jan 4 11:57 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls002 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 54,312 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 29.6 +CAF GHC.IO.Handle.FD 0.0 64.0 +CAF GHC.IO.Encoding 0.0 4.5 +CAF GHC.Conc.Signal 0.0 1.2 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 29.6 0.0 100.0 + f Main scc-prof-overloaded-calls002.hs:52:1-25 262 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:48:1-25 261 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:44:1-25 260 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:40:1-25 259 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:36:1-25 258 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:32:1-25 257 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:28:1-25 256 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 238 0 0.0 1.2 0.0 1.2 + CAF GHC.IO.Encoding 219 0 0.0 4.5 0.0 4.5 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 64.0 0.0 64.0 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample ===================================== @@ -0,0 +1,25 @@ + Thu Jan 4 11:26 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,304 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded001.hs:18:1-6 256 1 0.0 0.8 0.0 0.8 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample ===================================== @@ -0,0 +1,23 @@ + Thu Jan 4 11:55 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded002 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 56,472 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 32.7 +CAF GHC.IO.Handle.FD 0.0 61.5 +CAF GHC.IO.Encoding 0.0 4.3 +CAF GHC.Conc.Signal 0.0 1.1 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 32.7 0.0 100.0 + CAF GHC.Conc.Signal 238 0 0.0 1.1 0.0 1.1 + CAF GHC.IO.Encoding 219 0 0.0 4.3 0.0 4.3 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 61.5 0.0 61.5 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc001.prof copy.sample ===================================== @@ -0,0 +1,33 @@ + Wed Mar 29 06:17 2017 Time and Allocation Profiling Report (Final) + + scc001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 50,856 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 1.6 +CAF GHC.IO.Handle.FD 0.0 68.3 +CAF GHC.IO.Encoding 0.0 5.4 +CAF GHC.Conc.Signal 0.0 1.3 +main Main scc001.hs:(5,1)-(7,23) 0.0 22.2 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 111 0 0.0 1.6 0.0 100.0 + CAF Main 221 0 0.0 0.0 0.0 0.6 + (...) Main scc001.hs:16:1-16 227 1 0.0 0.0 0.0 0.0 + main Main scc001.hs:(5,1)-(7,23) 222 1 0.0 0.5 0.0 0.5 + h Main scc001.hs:16:1-16 226 1 0.0 0.0 0.0 0.0 + f Main scc001.hs:10:1-7 224 1 0.0 0.0 0.0 0.0 + g Main scc001.hs:13:1-7 225 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 216 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 206 0 0.0 5.4 0.0 5.4 + CAF GHC.IO.Encoding.Iconv 204 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 196 0 0.0 68.3 0.0 68.3 + CAF GHC.IO.Handle.Text 194 0 0.0 0.2 0.0 0.2 + CAF GHC.Show 179 0 0.0 0.6 0.0 0.6 + main Main scc001.hs:(5,1)-(7,23) 223 0 0.0 21.7 0.0 21.7 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96e962881646bc85ba66ad35bd47e9e0ff7f625b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/96e962881646bc85ba66ad35bd47e9e0ff7f625b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 20:27:48 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Thu, 04 Jan 2024 15:27:48 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T19520 Message-ID: <659714c492a51_3def44e3ac65038223@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/T19520 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T19520 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 20:49:34 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 04 Jan 2024 15:49:34 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-metadata-fail] gitlab-ci: Use ghc 9.2.8 for generate_jobs Message-ID: <659719dea094_295e727c17f8225c@gitlab.mail> Zubin pushed to branch wip/9.6.4-metadata-fail at Glasgow Haskell Compiler / GHC Commits: 6c38127e by Zubin Duggal at 2024-01-05T02:19:01+05:30 gitlab-ci: Use ghc 9.2.8 for generate_jobs Nix can't find ghc 9.2.4 for some reason, resulting in the lint-ci-config job failing - - - - - 1 changed file: - .gitlab/generate_jobs Changes: ===================================== .gitlab/generate_jobs ===================================== @@ -1,5 +1,5 @@ #!/usr/bin/env nix-shell -#!nix-shell -i bash -p cabal-install "haskell.packages.ghc924.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq +#!nix-shell -i bash -p cabal-install "haskell.packages.ghc928.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq # shellcheck shell=bash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c38127edcb01646137d9688c422354b0276334c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c38127edcb01646137d9688c422354b0276334c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 21:00:41 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Thu, 04 Jan 2024 16:00:41 -0500 Subject: [Git][ghc/ghc][wip/T19520] Remove VoidRep from PrimRep, introduce PrimOrVoidRep Message-ID: <65971c79c69c7_295e72e2bf94228e0@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T19520 at Glasgow Haskell Compiler / GHC Commits: cdf84275 by Krzysztof Gogolewski at 2024-01-04T22:00:21+01:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 25 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.Demand import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) @@ -857,7 +857,8 @@ primOpSig op GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep + = ReturnsVoid + | ReturnsPrim PrimRep | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value @@ -867,8 +868,11 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) | isUnboxedTupleTyCon tc -> ReturnsTuple | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -61,7 +61,7 @@ make_constr_itbls interp profile cons = where mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + let rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Cmm.Utils( import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -97,7 +97,6 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +135,10 @@ primElemRepCmmType Word64ElemRep = b64 primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +155,8 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -126,8 +126,9 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, + isGcPtrRep, primRepSizeB, primRepSizeW64_B, primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, @@ -1537,12 +1538,11 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep -- Unpacking of sum types is only supported since 9.6.1 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value #else - | BoxedRep !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep !(Maybe Levity) -- ^ Boxed, heap value #endif | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -1560,6 +1560,9 @@ data PrimRep | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1580,58 +1583,52 @@ instance Outputable PrimElemRep where ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1676,7 +1673,6 @@ primRepSizeB platform = \case DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep -- | Like primRepSizeB but assumes pointers/words are 8 words wide. @@ -1699,7 +1695,6 @@ primRepSizeW64_B = \case DoubleRep -> dOUBLE_SIZE AddrRep -> 8 BoxedRep{} -> 8 - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeW64_B rep primElemRepSizeB :: Platform -> PrimElemRep -> Int ===================================== compiler/GHC/HsToCore/Foreign/Utils.hs ===================================== @@ -57,7 +57,7 @@ primTyDescChar :: Platform -> Type -> Char primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' ===================================== compiler/GHC/Stg/Lift/Analysis.hs ===================================== @@ -418,7 +418,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -382,8 +382,6 @@ lintStgAppReps fun args = do = match_args actual_reps_left expected_reps_left -- Check for void rep (empty list) - -- Note typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.Stg.Syntax ( stgArgType, stgArgRep, stgArgRep1, + stgArgRepU, stgArgRep_maybe, stgCaseBndrInScope, @@ -80,7 +81,7 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -90,7 +91,7 @@ import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable @@ -177,10 +178,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -199,11 +200,15 @@ stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep_maybe :: StgArg -> Maybe [PrimRep] stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) --- | Assumes that the argument has one PrimRep, which holds after unarisation. +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -stgArgRep1 :: StgArg -> PrimRep +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep stgArgRep1 ty = typePrimRep1 (stgArgType ty) +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -607,13 +607,12 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -814,7 +813,7 @@ mapSumIdBinders alt_bndr args rhs rho0 mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -860,7 +859,7 @@ mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -922,8 +921,8 @@ mkUbxSum dc ty_args args0 us castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= stgArgRep1 arg - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout @@ -529,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (stgArgRep1 e) + arg_ty e = primRepCmmType platform (stgArgRepU e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -540,12 +540,14 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - let non_void VoidRep = False - non_void _ = True + let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep + rep_to_maybe VoidRep = Nothing + rep_to_maybe (NVRep rep) = Just rep + ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map stgArgRep1 es) + (mapMaybe (rep_to_maybe . stgArgRep1) es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -928,7 +930,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . idPrimRep + let bndr_ty = primRepCmmType platform . idPrimRepU tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -944,7 +946,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ idPrimRep arg)] + , not (isZeroBitTy $ idType arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -1378,10 +1380,10 @@ generatePrimCall d s p target _mb_unit _result_ty args layoutNativeCall profile NativePrimCall 0 - (primRepCmmType platform . stgArgRep1) + (primRepCmmType platform . stgArgRepU) nv_args - prim_args_offsets = mapFst stgArgRep1 args_offsets + prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 @@ -1457,7 +1459,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- ArgRep of what was actually pushed. pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] pargs _ [] = return [] pargs d (aa@(StgVarArg a):az) | Just t <- tyConAppTyCon_maybe (idType a) @@ -1470,7 +1472,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) + return ((code, NVRep AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az return ((code_a, stgArgRep1 aa) : rest) @@ -1483,8 +1485,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x + | VoidRep:xs <- a_reps_pushed_r_to_l = reverse xs | otherwise = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" @@ -1494,10 +1495,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- d_after_args is the stack depth once the args are on. -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) + r_rep = maybe_getCCallReturnRep result_ty {- Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call @@ -1570,10 +1568,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- this is a V (tag). r_sizeW = repSizeWords platform r_rep d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) -- generate the marshalling code we're going to call @@ -1611,17 +1608,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) + `snocOL` RETURN (toArgRepOrV platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) = case r of - VoidRep -> FFIVoid IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> FFISInt8 @@ -1668,7 +1665,7 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- --- to Just IntRep +-- to NVRep IntRep -- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert @@ -1676,16 +1673,16 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- --- to Nothing +-- to VoidRep -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) in case typePrimRep r_ty of - [] -> Nothing - [rep] -> Just rep + [] -> VoidRep + [rep] -> NVRep rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2131,10 +2128,10 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -2171,7 +2168,7 @@ mkSlideW !n !ws atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (stgArgRep1 e) +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -253,8 +253,8 @@ cgDataCon mn data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) ] ===================================== compiler/GHC/StgToCmm/ArgRep.hs ===================================== @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ module GHC.StgToCmm.ArgRep ( import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -68,7 +68,6 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ toArgRep platform rep = case rep of 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ argRepSizeW platform = \case ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -382,7 +382,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -18,7 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -176,24 +176,27 @@ assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (stgArgRep1 arg', arg')) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -205,4 +205,4 @@ idToReg :: Platform -> NonVoid Id -> LocalReg -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -488,7 +488,7 @@ accurate update would complexify the implementation and doesn't seem worth it. -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -522,9 +522,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -330,8 +330,8 @@ getArgRepsAmodes args = do where getArgRepAmode platform arg = case stgArgRep1 arg of VoidRep -> return (V, Nothing) - rep -> do expr <- getArgAmode (NonVoid arg) - return (toArgRep platform rep, Just expr) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -438,7 +438,6 @@ mkVirtHeapOffsetsWithPadding -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -520,13 +519,13 @@ mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -52,7 +52,6 @@ cgLit (LitString s) = -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1720,7 +1720,7 @@ emitPrimOp cfg primop = -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do regs <- case result_info of - ReturnsPrim VoidRep -> pure [] + ReturnsVoid -> pure [] ReturnsPrim rep -> do reg <- newTemp (primRepCmmType platform rep) pure [reg] ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -615,7 +615,7 @@ tickySlowCall lf_info args = do tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform . stgArgRep1) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/StgToJS/Arg.hs ===================================== @@ -120,7 +120,7 @@ genStaticArg a = case a of Nothing -> reg Just expr -> unfloated expr where - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -162,7 +162,7 @@ genArg a = case a of where -- if our argument is a joinid, it can be an unboxed tuple r :: HasDebugCallStack => JSRep - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -351,7 +351,7 @@ genBody ctx startReg args e typ = do -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -20,6 +20,7 @@ module GHC.StgToJS.Utils , typeJSRep , unaryTypeJSRep , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType , primRepSize , mkArityTag @@ -196,10 +197,9 @@ typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep -unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut) +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep -primRepToJSRep VoidRep = VoidV primRepToJSRep (BoxedRep _) = PtrV primRepToJSRep IntRep = IntV primRepToJSRep Int8Rep = IntV @@ -216,6 +216,10 @@ primRepToJSRep FloatRep = DoubleV primRepToJSRep DoubleRep = DoubleV primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,7 +1525,6 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. - -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys -- And then get the actual size of the unpacked constructor. rep_size = sum $ map primRepSizeW64_B prim_reps ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -11,11 +11,11 @@ module GHC.Types.RepType isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type @@ -38,7 +38,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -80,15 +80,6 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty - -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts @@ -129,7 +120,7 @@ countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = length (typePrimRep arg) `max` 1 + countFunRepArgs (n - 1) res | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -308,7 +299,6 @@ repSlotTy reps = case reps of _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -391,8 +381,7 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -441,18 +430,29 @@ See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) +The RuntimeRep of a void value is TupleRep '[]. When converting +a TupleRep '[] into a list of PrimReps, we get an empty list. + +After the unariser, all identifiers have exactly one PrimRep, but +void arguments still exist. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) + +Thus, we have -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +1. typePrimRep :: Type -> [PrimRep] + which returns the list -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. data PrimOrVoidRep = VoidRep | NVRep PrimRep + typePrimRep1 :: Type -> PrimOrVoidRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -546,17 +546,22 @@ typePrimRep ty = kindPrimRep (text "typePrimRep" <+> typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -567,15 +572,6 @@ tyConPrimRep tc where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -603,8 +599,6 @@ kindPrimRep_maybe ki -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -617,8 +611,7 @@ runtimeRepPrimRep doc rr_ty -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -634,7 +627,6 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cdf84275eb1add5186d5b0485e31c36d4533f831 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cdf84275eb1add5186d5b0485e31c36d4533f831 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Thu Jan 4 23:51:43 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 04 Jan 2024 18:51:43 -0500 Subject: [Git][ghc/ghc][ghc-9.6] 2 commits: ci: Allow release-hackage-lint to fail Message-ID: <6597448f98d16_295e7250d2d2030969@gitlab.mail> Zubin pushed to branch ghc-9.6 at Glasgow Haskell Compiler / GHC Commits: b3ddb687 by Zubin Duggal at 2024-01-04T21:30:21+05:30 ci: Allow release-hackage-lint to fail Otherwise it blocks the ghcup metadata pipeline from running. (cherry picked from commit e8960b0af7904f7646915e1ba847e18bfbf3067c) Metric Decrease: MultiLayerModulesTH_Make - - - - - 6c38127e by Zubin Duggal at 2024-01-05T02:19:01+05:30 gitlab-ci: Use ghc 9.2.8 for generate_jobs Nix can't find ghc 9.2.4 for some reason, resulting in the lint-ci-config job failing - - - - - 2 changed files: - .gitlab-ci.yml - .gitlab/generate_jobs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -770,6 +770,10 @@ release-hackage-lint: rules: - if: '$RELEASE_JOB == "yes"' extends: .hackage + # The ghcup metadata pipeline requires all prior jobs to + # pass. The hackage job can easily fail due to API changes + # or similar - so we allow it to fail. + allow_failure: true variables: # No slow-validate bindist on release pipeline EXTRA_HC_OPTS: "-dlint" ===================================== .gitlab/generate_jobs ===================================== @@ -1,5 +1,5 @@ #!/usr/bin/env nix-shell -#!nix-shell -i bash -p cabal-install "haskell.packages.ghc924.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq +#!nix-shell -i bash -p cabal-install "haskell.packages.ghc928.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq # shellcheck shell=bash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/615a63d39ecbeba863199d0447c975ea53a4c84c...6c38127edcb01646137d9688c422354b0276334c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/615a63d39ecbeba863199d0447c975ea53a4c84c...6c38127edcb01646137d9688c422354b0276334c You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 00:57:28 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 04 Jan 2024 19:57:28 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Fix VoidRep handling in ghci debugger Message-ID: <659753f82d03d_295e7273a46a036873@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 76a83aed by Krzysztof Gogolewski at 2024-01-04T19:57:09-05:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - c89c7490 by Krzysztof Gogolewski at 2024-01-04T19:57:09-05:00 VoidRep-related refactor * In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep, bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1. All of them were duplicates. * In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out. * In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out VoidRep from the result of typePrimRep. But typePrimRep never returns VoidRep - remove the filtering. - - - - - 13 changed files: - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - + testsuite/tests/ghci.debugger/scripts/T24306.hs - + testsuite/tests/ghci.debugger/scripts/T24306.script - + testsuite/tests/ghci.debugger/scripts/T24306.stdout - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -381,9 +381,9 @@ lintStgAppReps fun args = do | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep which can be either an empty list *or* [VoidRep] - -- No, typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. + -- Check for void rep (empty list) + -- Note typePrimRep_maybe will never return a result containing VoidRep. + -- We should refactor to make this obvious from the types. | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left @@ -410,7 +410,6 @@ lintStgAppReps fun args = do text "unarised?:" <> ppr (lf_unarised lf)) where isVoidRep [] = True - isVoidRep [VoidRep] = True isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -808,15 +808,13 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] id_vars = [v | StgVarArg v <- id_arg_exprs] - -- Output types for the field binders based on their rep - id_tys = map primRepToType fld_reps - typed_id_arg_input = assert (equalLength id_vars id_tys) $ - zip3 id_vars id_tys uss + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss - mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,tar_type,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -834,7 +832,7 @@ mapSumIdBinders alt_bndr args rhs rho0 typed_id_args = map StgVarArg typed_ids -- pprTrace "mapSumIdBinders" - -- (text "id_tys" <+> ppr id_tys $$ + -- (text "fld_reps" <+> ppr fld_reps $$ -- text "id_args" <+> ppr id_arg_exprs $$ -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts @@ -925,8 +923,7 @@ mkUbxSum dc ty_args args0 us castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRep1 arg - , out_ty <- primRepToType $ slotPrimRep slot_ty - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty + , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,9 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, + addIdReps, addArgReps, + nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap @@ -80,7 +82,6 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified GHC.Data.FiniteMap as Map @@ -372,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap - bits = argBits platform (reverse (map (bcIdArgRep platform) all_args)) + bits = argBits platform (reverse (map (idArgRep platform) all_args)) bitmap_size = genericLength bits bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -528,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (atomPrimRep e) + arg_ty e = primRepCmmType platform (stgArgRep1 e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -544,7 +545,7 @@ returnUnboxedTuple d s p es = do ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map atomPrimRep es) + (filter non_void $ map stgArgRep1 es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -745,11 +746,7 @@ mkConAppCode orig_d _ p con args = app_code let platform = profilePlatform profile non_voids = - [ NonVoid (prim_rep, arg) - | arg <- args - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] + addArgReps (nonVoidStgArgs args) (_, _, args_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader non_voids @@ -931,7 +928,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . bcIdPrimRep + let bndr_ty = primRepCmmType platform . idPrimRep tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -947,7 +944,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ bcIdPrimRep arg)] + , not (isVoidRep $ idPrimRep arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -956,9 +953,7 @@ doCase d s p scrut bndr alts | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = mkVirtHeapOffsets profile NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] + (addIdReps (nonVoidIds real_bndrs)) size = WordOff tot_wds stack_bot = d_alts + wordsToBytes platform size @@ -1052,7 +1047,7 @@ doCase d s p scrut bndr alts rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p spread id offset | isUnboxedTupleType (idType id) || isUnboxedSumType (idType id) = Nothing - | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) | otherwise = Nothing where rel_offset = bytesToWords platform (d - offset) @@ -1478,7 +1473,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args return ((code, AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep aa) : rest) + return ((code_a, stgArgRep1 aa) : rest) code_n_reps <- pargs d0 args_r_to_l let @@ -2126,7 +2121,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup idSizeW :: Platform -> Id -> WordOff -idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform idSizeCon :: Platform -> Id -> ByteOff idSizeCon platform var @@ -2136,17 +2131,7 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) - -bcIdArgRep :: Platform -> Id -> ArgRep -bcIdArgRep platform = toArgRep platform . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | rep :| [] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2185,12 +2170,8 @@ mkSlideW !n !ws -atomPrimRep :: StgArg -> PrimRep -atomPrimRep (StgVarArg v) = bcIdPrimRep v -atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) - atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (atomPrimRep e) +atomRep platform e = toArgRep platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -257,7 +257,7 @@ cgDataCon mn data_con arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) - , not (isVoidRep rep_ty) ] + ] ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -328,10 +328,10 @@ getArgRepsAmodes args = do platform <- profilePlatform <$> getProfile mapM (getArgRepAmode platform) args where getArgRepAmode platform arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep platform (stgArgRep1 arg) + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -603,12 +603,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, -- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | args `lengthIs` arity = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map stgArgRep1 (drop arity args)) + tickySlowCallPat (drop arity args) tickyKnownCallTooFewArgs :: FCode () tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") @@ -610,12 +610,12 @@ tickySlowCall lf_info args = do if isKnownFun lf_info then tickyKnownCallTooFewArgs else tickyUnknownCall - tickySlowCallPat (map stgArgRep1 args) + tickySlowCallPat args -tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform) args + let argReps = map (toArgRep platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,11 +1525,10 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. + -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys - -- Void types are erased when unpacked so we - nv_prim_reps = filter (not . isVoidRep) prim_reps -- And then get the actual size of the unpacked constructor. - rep_size = sum $ map primRepSizeW64_B nv_prim_reps + rep_size = sum $ map primRepSizeW64_B prim_reps in rep_size <= 8 is_sum :: [DataCon] -> Bool ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -160,21 +160,18 @@ dataConRuntimeRepStrictness dc = go repMarks repTys [] where go (mark:marks) (ty:types) out_marks - -- Zero-width argument, mark is irrelevant at runtime. - | -- pprTrace "VoidTy" (ppr ty) $ - (isZeroBitTy ty) - = go marks types out_marks - -- Single rep argument, e.g. Int - -- Keep mark as-is - | [_] <- reps - = go marks types (mark:out_marks) - -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) - -- Make up one non-strict mark per runtime argument. - | otherwise -- TODO: Assert real_reps /= null - = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks) + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) where reps = typePrimRep ty - real_reps = filter (not . isVoidRep) $ reps go [] [] out_marks = reverse out_marks go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) ===================================== testsuite/tests/ghci.debugger/scripts/T24306.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-} +module T24306 where + +import GHC.Exts + +newtype A = MkA (# #) +data T = T Int# A Int# + +x = T 1# (MkA (# #)) 2# ===================================== testsuite/tests/ghci.debugger/scripts/T24306.script ===================================== @@ -0,0 +1,2 @@ +:load T24306 +:force x ===================================== testsuite/tests/ghci.debugger/scripts/T24306.stdout ===================================== @@ -0,0 +1 @@ +x = T 1 (MkA (##)) 2 ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -140,3 +140,4 @@ test('break030', ['break030.script'], ) test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script']) +test('T24306', normal, ghci_script, ['T24306.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5...c89c74905dc197b3931b23aafe04b5c79c7439dd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff515cd42501eb4cb20a5ff63f2cf8637d9f7bd5...c89c74905dc197b3931b23aafe04b5c79c7439dd You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 07:07:45 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 Jan 2024 02:07:45 -0500 Subject: [Git][ghc/ghc][master] Fix VoidRep handling in ghci debugger Message-ID: <6597aac1c8052_1713169470b04568a5@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 67dbcc0a by Krzysztof Gogolewski at 2024-01-05T02:07:18-05:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - 5 changed files: - compiler/GHC/Runtime/Heap/Inspect.hs - + testsuite/tests/ghci.debugger/scripts/T24306.hs - + testsuite/tests/ghci.debugger/scripts/T24306.script - + testsuite/tests/ghci.debugger/scripts/T24306.stdout - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== testsuite/tests/ghci.debugger/scripts/T24306.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-} +module T24306 where + +import GHC.Exts + +newtype A = MkA (# #) +data T = T Int# A Int# + +x = T 1# (MkA (# #)) 2# ===================================== testsuite/tests/ghci.debugger/scripts/T24306.script ===================================== @@ -0,0 +1,2 @@ +:load T24306 +:force x ===================================== testsuite/tests/ghci.debugger/scripts/T24306.stdout ===================================== @@ -0,0 +1 @@ +x = T 1 (MkA (##)) 2 ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -140,3 +140,4 @@ test('break030', ['break030.script'], ) test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script']) +test('T24306', normal, ghci_script, ['T24306.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67dbcc0aea442a713d8fb54953ab684250794e8a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67dbcc0aea442a713d8fb54953ab684250794e8a You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 07:08:26 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 05 Jan 2024 02:08:26 -0500 Subject: [Git][ghc/ghc][master] VoidRep-related refactor Message-ID: <6597aae9ef66c_17131695f3238597d8@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 90ea574e by Krzysztof Gogolewski at 2024-01-05T02:07:54-05:00 VoidRep-related refactor * In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep, bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1. All of them were duplicates. * In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out. * In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out VoidRep from the result of typePrimRep. But typePrimRep never returns VoidRep - remove the filtering. - - - - - 8 changed files: - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -381,9 +381,9 @@ lintStgAppReps fun args = do | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep which can be either an empty list *or* [VoidRep] - -- No, typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. + -- Check for void rep (empty list) + -- Note typePrimRep_maybe will never return a result containing VoidRep. + -- We should refactor to make this obvious from the types. | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left @@ -410,7 +410,6 @@ lintStgAppReps fun args = do text "unarised?:" <> ppr (lf_unarised lf)) where isVoidRep [] = True - isVoidRep [VoidRep] = True isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -808,15 +808,13 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] id_vars = [v | StgVarArg v <- id_arg_exprs] - -- Output types for the field binders based on their rep - id_tys = map primRepToType fld_reps - typed_id_arg_input = assert (equalLength id_vars id_tys) $ - zip3 id_vars id_tys uss + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss - mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,tar_type,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -834,7 +832,7 @@ mapSumIdBinders alt_bndr args rhs rho0 typed_id_args = map StgVarArg typed_ids -- pprTrace "mapSumIdBinders" - -- (text "id_tys" <+> ppr id_tys $$ + -- (text "fld_reps" <+> ppr fld_reps $$ -- text "id_args" <+> ppr id_arg_exprs $$ -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts @@ -925,8 +923,7 @@ mkUbxSum dc ty_args args0 us castArg us slot_ty arg -- Cast the argument to the type of the slot if required | slotPrimRep slot_ty /= stgArgRep1 arg - , out_ty <- primRepToType $ slotPrimRep slot_ty - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty + , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,9 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, + addIdReps, addArgReps, + nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap @@ -80,7 +82,6 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified GHC.Data.FiniteMap as Map @@ -372,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap - bits = argBits platform (reverse (map (bcIdArgRep platform) all_args)) + bits = argBits platform (reverse (map (idArgRep platform) all_args)) bitmap_size = genericLength bits bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -528,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (atomPrimRep e) + arg_ty e = primRepCmmType platform (stgArgRep1 e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -544,7 +545,7 @@ returnUnboxedTuple d s p es = do ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map atomPrimRep es) + (filter non_void $ map stgArgRep1 es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -745,11 +746,7 @@ mkConAppCode orig_d _ p con args = app_code let platform = profilePlatform profile non_voids = - [ NonVoid (prim_rep, arg) - | arg <- args - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] + addArgReps (nonVoidStgArgs args) (_, _, args_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader non_voids @@ -931,7 +928,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . bcIdPrimRep + let bndr_ty = primRepCmmType platform . idPrimRep tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -947,7 +944,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ bcIdPrimRep arg)] + , not (isVoidRep $ idPrimRep arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -956,9 +953,7 @@ doCase d s p scrut bndr alts | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = mkVirtHeapOffsets profile NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] + (addIdReps (nonVoidIds real_bndrs)) size = WordOff tot_wds stack_bot = d_alts + wordsToBytes platform size @@ -1052,7 +1047,7 @@ doCase d s p scrut bndr alts rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p spread id offset | isUnboxedTupleType (idType id) || isUnboxedSumType (idType id) = Nothing - | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) | otherwise = Nothing where rel_offset = bytesToWords platform (d - offset) @@ -1478,7 +1473,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args return ((code, AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep aa) : rest) + return ((code_a, stgArgRep1 aa) : rest) code_n_reps <- pargs d0 args_r_to_l let @@ -2126,7 +2121,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup idSizeW :: Platform -> Id -> WordOff -idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform idSizeCon :: Platform -> Id -> ByteOff idSizeCon platform var @@ -2136,17 +2131,7 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) - -bcIdArgRep :: Platform -> Id -> ArgRep -bcIdArgRep platform = toArgRep platform . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | rep :| [] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) repSizeWords :: Platform -> PrimRep -> WordOff repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) @@ -2185,12 +2170,8 @@ mkSlideW !n !ws -atomPrimRep :: StgArg -> PrimRep -atomPrimRep (StgVarArg v) = bcIdPrimRep v -atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) - atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (atomPrimRep e) +atomRep platform e = toArgRep platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -257,7 +257,7 @@ cgDataCon mn data_con arg_reps = [ NonVoid rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) - , not (isVoidRep rep_ty) ] + ] ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -328,10 +328,10 @@ getArgRepsAmodes args = do platform <- profilePlatform <$> getProfile mapM (getArgRepAmode platform) args where getArgRepAmode platform arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep platform (stgArgRep1 arg) + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -603,12 +603,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, -- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | args `lengthIs` arity = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map stgArgRep1 (drop arity args)) + tickySlowCallPat (drop arity args) tickyKnownCallTooFewArgs :: FCode () tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") @@ -610,12 +610,12 @@ tickySlowCall lf_info args = do if isKnownFun lf_info then tickyKnownCallTooFewArgs else tickyUnknownCall - tickySlowCallPat (map stgArgRep1 args) + tickySlowCallPat args -tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform) args + let argReps = map (toArgRep platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,11 +1525,10 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. + -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys - -- Void types are erased when unpacked so we - nv_prim_reps = filter (not . isVoidRep) prim_reps -- And then get the actual size of the unpacked constructor. - rep_size = sum $ map primRepSizeW64_B nv_prim_reps + rep_size = sum $ map primRepSizeW64_B prim_reps in rep_size <= 8 is_sum :: [DataCon] -> Bool ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -160,21 +160,18 @@ dataConRuntimeRepStrictness dc = go repMarks repTys [] where go (mark:marks) (ty:types) out_marks - -- Zero-width argument, mark is irrelevant at runtime. - | -- pprTrace "VoidTy" (ppr ty) $ - (isZeroBitTy ty) - = go marks types out_marks - -- Single rep argument, e.g. Int - -- Keep mark as-is - | [_] <- reps - = go marks types (mark:out_marks) - -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) - -- Make up one non-strict mark per runtime argument. - | otherwise -- TODO: Assert real_reps /= null - = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks) + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) where reps = typePrimRep ty - real_reps = filter (not . isVoidRep) $ reps go [] [] out_marks = reverse out_marks go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90ea574e9cdac4c57e91ce7fdae7fbbccf344e24 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/90ea574e9cdac4c57e91ce7fdae7fbbccf344e24 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 10:06:11 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 05 Jan 2024 05:06:11 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-metadata-fail] gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Message-ID: <6597d493417bc_171316e541678759de@gitlab.mail> Zubin pushed to branch wip/9.6.4-metadata-fail at Glasgow Haskell Compiler / GHC Commits: ea1e8743 by Zubin Duggal at 2024-01-05T15:35:51+05:30 gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Nix can't find ghc 9.2.4 for some reason, resulting in the lint-ci-config job failing - - - - - 1 changed file: - .gitlab/generate_job_metadata Changes: ===================================== .gitlab/generate_job_metadata ===================================== @@ -1,5 +1,5 @@ #! /usr/bin/env nix-shell -#!nix-shell -i bash -p cabal-install "haskell.packages.ghc924.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq +#!nix-shell -i bash -p cabal-install "haskell.packages.ghc928.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq cd "$(dirname "${BASH_SOURCE[0]}")" cabal run gen_ci -- metadata jobs-metadata.json View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea1e874311a424e5ac1df9da259c5800639c9799 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea1e874311a424e5ac1df9da259c5800639c9799 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 11:48:42 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Fri, 05 Jan 2024 06:48:42 -0500 Subject: [Git][ghc/ghc][wip/T19520] 3 commits: Fix VoidRep handling in ghci debugger Message-ID: <6597ec9a90139_112640d8b36412880@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T19520 at Glasgow Haskell Compiler / GHC Commits: 67dbcc0a by Krzysztof Gogolewski at 2024-01-05T02:07:18-05:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - 90ea574e by Krzysztof Gogolewski at 2024-01-05T02:07:54-05:00 VoidRep-related refactor * In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep, bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1. All of them were duplicates. * In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out. * In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out VoidRep from the result of typePrimRep. But typePrimRep never returns VoidRep - remove the filtering. - - - - - f58d5a84 by Krzysztof Gogolewski at 2024-01-05T12:47:31+01:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - + testsuite/tests/ghci.debugger/scripts/T24306.hs - + testsuite/tests/ghci.debugger/scripts/T24306.script - + testsuite/tests/ghci.debugger/scripts/T24306.stdout - testsuite/tests/ghci.debugger/scripts/all.T Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.Demand import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) @@ -857,7 +857,8 @@ primOpSig op GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep + = ReturnsVoid + | ReturnsPrim PrimRep | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value @@ -867,8 +868,11 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) | isUnboxedTupleTyCon tc -> ReturnsTuple | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -61,7 +61,7 @@ make_constr_itbls interp profile cons = where mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + let rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Cmm.Utils( import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -97,7 +97,6 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +135,10 @@ primElemRepCmmType Word64ElemRep = b64 primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +155,8 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -126,8 +126,9 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, + isGcPtrRep, primRepSizeB, primRepSizeW64_B, primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, @@ -1537,12 +1538,11 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep -- Unpacking of sum types is only supported since 9.6.1 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value #else - | BoxedRep !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep !(Maybe Levity) -- ^ Boxed, heap value #endif | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -1560,6 +1560,9 @@ data PrimRep | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1580,58 +1583,52 @@ instance Outputable PrimElemRep where ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1676,7 +1673,6 @@ primRepSizeB platform = \case DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep -- | Like primRepSizeB but assumes pointers/words are 8 words wide. @@ -1699,7 +1695,6 @@ primRepSizeW64_B = \case DoubleRep -> dOUBLE_SIZE AddrRep -> 8 BoxedRep{} -> 8 - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeW64_B rep primElemRepSizeB :: Platform -> PrimElemRep -> Int ===================================== compiler/GHC/HsToCore/Foreign/Utils.hs ===================================== @@ -57,7 +57,7 @@ primTyDescChar :: Platform -> Type -> Char primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -888,13 +888,13 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) ===================================== compiler/GHC/Stg/Lift/Analysis.hs ===================================== @@ -418,7 +418,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -381,9 +381,7 @@ lintStgAppReps fun args = do | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep which can be either an empty list *or* [VoidRep] - -- No, typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. + -- Check for void rep (empty list) | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left @@ -410,7 +408,6 @@ lintStgAppReps fun args = do text "unarised?:" <> ppr (lf_unarised lf)) where isVoidRep [] = True - isVoidRep [VoidRep] = True isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.Stg.Syntax ( stgArgType, stgArgRep, stgArgRep1, + stgArgRepU, stgArgRep_maybe, stgCaseBndrInScope, @@ -80,7 +81,7 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -90,7 +91,7 @@ import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable @@ -177,10 +178,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -199,11 +200,15 @@ stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep_maybe :: StgArg -> Maybe [PrimRep] stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) --- | Assumes that the argument has one PrimRep, which holds after unarisation. +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -stgArgRep1 :: StgArg -> PrimRep +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep stgArgRep1 ty = typePrimRep1 (stgArgType ty) +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -607,13 +607,12 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -808,15 +807,13 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] id_vars = [v | StgVarArg v <- id_arg_exprs] - -- Output types for the field binders based on their rep - id_tys = map primRepToType fld_reps - typed_id_arg_input = assert (equalLength id_vars id_tys) $ - zip3 id_vars id_tys uss + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss - mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,tar_type,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -834,7 +831,7 @@ mapSumIdBinders alt_bndr args rhs rho0 typed_id_args = map StgVarArg typed_ids -- pprTrace "mapSumIdBinders" - -- (text "id_tys" <+> ppr id_tys $$ + -- (text "fld_reps" <+> ppr fld_reps $$ -- text "id_args" <+> ppr id_arg_exprs $$ -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts @@ -862,7 +859,7 @@ mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -924,9 +921,8 @@ mkUbxSum dc ty_args args0 us castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= stgArgRep1 arg - , out_ty <- primRepToType $ slotPrimRep slot_ty - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ typePrimRep1 out_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,9 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds ) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, + addIdReps, addArgReps, + nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) import GHC.Data.Bitmap @@ -80,7 +82,6 @@ import Data.Coerce (coerce) import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified GHC.Data.FiniteMap as Map @@ -372,7 +373,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) -- make the arg bitmap - bits = argBits platform (reverse (map (bcIdArgRep platform) all_args)) + bits = argBits platform (reverse (map (idArgRep platform) all_args)) bitmap_size = genericLength bits bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body @@ -528,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (atomPrimRep e) + arg_ty e = primRepCmmType platform (stgArgRepU e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -539,12 +540,14 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - let non_void VoidRep = False - non_void _ = True + let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep + rep_to_maybe VoidRep = Nothing + rep_to_maybe (NVRep rep) = Just rep + ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map atomPrimRep es) + (mapMaybe (rep_to_maybe . stgArgRep1) es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -745,11 +748,7 @@ mkConAppCode orig_d _ p con args = app_code let platform = profilePlatform profile non_voids = - [ NonVoid (prim_rep, arg) - | arg <- args - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] + addArgReps (nonVoidStgArgs args) (_, _, args_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader non_voids @@ -931,7 +930,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . bcIdPrimRep + let bndr_ty = primRepCmmType platform . idPrimRepU tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -947,7 +946,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ bcIdPrimRep arg)] + , not (isZeroBitTy $ idType arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -956,9 +955,7 @@ doCase d s p scrut bndr alts | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = mkVirtHeapOffsets profile NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] + (addIdReps (nonVoidIds real_bndrs)) size = WordOff tot_wds stack_bot = d_alts + wordsToBytes platform size @@ -1052,7 +1049,7 @@ doCase d s p scrut bndr alts rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p spread id offset | isUnboxedTupleType (idType id) || isUnboxedSumType (idType id) = Nothing - | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) | otherwise = Nothing where rel_offset = bytesToWords platform (d - offset) @@ -1383,10 +1380,10 @@ generatePrimCall d s p target _mb_unit _result_ty args layoutNativeCall profile NativePrimCall 0 - (primRepCmmType platform . stgArgRep1) + (primRepCmmType platform . stgArgRepU) nv_args - prim_args_offsets = mapFst stgArgRep1 args_offsets + prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 @@ -1462,7 +1459,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- ArgRep of what was actually pushed. pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] pargs _ [] = return [] pargs d (aa@(StgVarArg a):az) | Just t <- tyConAppTyCon_maybe (idType a) @@ -1475,10 +1472,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) + return ((code, NVRep AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep aa) : rest) + return ((code_a, stgArgRep1 aa) : rest) code_n_reps <- pargs d0 args_r_to_l let @@ -1488,8 +1485,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x + | VoidRep:xs <- a_reps_pushed_r_to_l = reverse xs | otherwise = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" @@ -1499,10 +1495,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- d_after_args is the stack depth once the args are on. -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) + r_rep = maybe_getCCallReturnRep result_ty {- Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call @@ -1575,10 +1568,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- this is a V (tag). r_sizeW = repSizeWords platform r_rep d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) -- generate the marshalling code we're going to call @@ -1616,17 +1608,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) + `snocOL` RETURN (toArgRepOrV platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) = case r of - VoidRep -> FFIVoid IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> FFISInt8 @@ -1673,7 +1665,7 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- --- to Just IntRep +-- to NVRep IntRep -- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert @@ -1681,16 +1673,16 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- --- to Nothing +-- to VoidRep -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) in case typePrimRep r_ty of - [] -> Nothing - [rep] -> Just rep + [] -> VoidRep + [rep] -> NVRep rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2126,7 +2118,7 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff lookupBCEnv_maybe = Map.lookup idSizeW :: Platform -> Id -> WordOff -idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform idSizeCon :: Platform -> Id -> ByteOff idSizeCon platform var @@ -2136,20 +2128,10 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) - -bcIdArgRep :: Platform -> Id -> ArgRep -bcIdArgRep platform = toArgRep platform . bcIdPrimRep + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | rep :| [] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -2185,12 +2167,8 @@ mkSlideW !n !ws -atomPrimRep :: StgArg -> PrimRep -atomPrimRep (StgVarArg v) = bcIdPrimRep v -atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) - atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (atomPrimRep e) +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -253,11 +253,11 @@ cgDataCon mn data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) - , not (isVoidRep rep_ty) ] + ] ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on ===================================== compiler/GHC/StgToCmm/ArgRep.hs ===================================== @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ module GHC.StgToCmm.ArgRep ( import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -68,7 +68,6 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ toArgRep platform rep = case rep of 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ argRepSizeW platform = \case ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -382,7 +382,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -18,7 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -176,24 +176,27 @@ assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (stgArgRep1 arg', arg')) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -205,4 +205,4 @@ idToReg :: Platform -> NonVoid Id -> LocalReg -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -488,7 +488,7 @@ accurate update would complexify the implementation and doesn't seem worth it. -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -522,9 +522,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -328,10 +328,10 @@ getArgRepsAmodes args = do platform <- profilePlatform <$> getProfile mapM (getArgRepAmode platform) args where getArgRepAmode platform arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep platform (stgArgRep1 arg) + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -438,7 +438,6 @@ mkVirtHeapOffsetsWithPadding -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -520,13 +519,13 @@ mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- @@ -603,12 +602,7 @@ getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, -- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (stgArgRep1 arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -52,7 +52,6 @@ cgLit (LitString s) = -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1720,7 +1720,7 @@ emitPrimOp cfg primop = -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do regs <- case result_info of - ReturnsPrim VoidRep -> pure [] + ReturnsVoid -> pure [] ReturnsPrim rep -> do reg <- newTemp (primRepCmmType platform rep) pure [reg] ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -587,7 +587,7 @@ tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | args `lengthIs` arity = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map stgArgRep1 (drop arity args)) + tickySlowCallPat (drop arity args) tickyKnownCallTooFewArgs :: FCode () tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") @@ -610,12 +610,12 @@ tickySlowCall lf_info args = do if isKnownFun lf_info then tickyKnownCallTooFewArgs else tickyUnknownCall - tickySlowCallPat (map stgArgRep1 args) + tickySlowCallPat args -tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/StgToJS/Arg.hs ===================================== @@ -120,7 +120,7 @@ genStaticArg a = case a of Nothing -> reg Just expr -> unfloated expr where - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -162,7 +162,7 @@ genArg a = case a of where -- if our argument is a joinid, it can be an unboxed tuple r :: HasDebugCallStack => JSRep - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -351,7 +351,7 @@ genBody ctx startReg args e typ = do -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -20,6 +20,7 @@ module GHC.StgToJS.Utils , typeJSRep , unaryTypeJSRep , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType , primRepSize , mkArityTag @@ -196,10 +197,9 @@ typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep -unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut) +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep -primRepToJSRep VoidRep = VoidV primRepToJSRep (BoxedRep _) = PtrV primRepToJSRep IntRep = IntV primRepToJSRep Int8Rep = IntV @@ -216,6 +216,10 @@ primRepToJSRep FloatRep = DoubleV primRepToJSRep DoubleRep = DoubleV primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1526,10 +1526,8 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty is_small_rep = let -- Neccesary to look through unboxed tuples. prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys - -- Void types are erased when unpacked so we - nv_prim_reps = filter (not . isVoidRep) prim_reps -- And then get the actual size of the unpacked constructor. - rep_size = sum $ map primRepSizeW64_B nv_prim_reps + rep_size = sum $ map primRepSizeW64_B prim_reps in rep_size <= 8 is_sum :: [DataCon] -> Bool ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -11,11 +11,11 @@ module GHC.Types.RepType isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type @@ -38,7 +38,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -80,15 +80,6 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty - -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts @@ -129,7 +120,7 @@ countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = length (typePrimRep arg) `max` 1 + countFunRepArgs (n - 1) res | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -160,21 +151,18 @@ dataConRuntimeRepStrictness dc = go repMarks repTys [] where go (mark:marks) (ty:types) out_marks - -- Zero-width argument, mark is irrelevant at runtime. - | -- pprTrace "VoidTy" (ppr ty) $ - (isZeroBitTy ty) - = go marks types out_marks - -- Single rep argument, e.g. Int - -- Keep mark as-is - | [_] <- reps - = go marks types (mark:out_marks) - -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) - -- Make up one non-strict mark per runtime argument. - | otherwise -- TODO: Assert real_reps /= null - = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks) + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) where reps = typePrimRep ty - real_reps = filter (not . isVoidRep) $ reps go [] [] out_marks = reverse out_marks go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) @@ -311,7 +299,6 @@ repSlotTy reps = case reps of _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -394,8 +381,7 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -444,18 +430,29 @@ See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) +The RuntimeRep of a void value is TupleRep '[]. When converting +a TupleRep '[] into a list of PrimReps, we get an empty list. + +After the unariser, all identifiers have exactly one PrimRep, but +void arguments still exist. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) + +Thus, we have -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +1. typePrimRep :: Type -> [PrimRep] + which returns the list -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. data PrimOrVoidRep = VoidRep | NVRep PrimRep + typePrimRep1 :: Type -> PrimOrVoidRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -549,17 +546,22 @@ typePrimRep ty = kindPrimRep (text "typePrimRep" <+> typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -570,15 +572,6 @@ tyConPrimRep tc where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -606,8 +599,6 @@ kindPrimRep_maybe ki -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -620,8 +611,7 @@ runtimeRepPrimRep doc rr_ty -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -637,7 +627,6 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy ===================================== testsuite/tests/ghci.debugger/scripts/T24306.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples, UnliftedNewtypes, DataKinds, MagicHash #-} +module T24306 where + +import GHC.Exts + +newtype A = MkA (# #) +data T = T Int# A Int# + +x = T 1# (MkA (# #)) 2# ===================================== testsuite/tests/ghci.debugger/scripts/T24306.script ===================================== @@ -0,0 +1,2 @@ +:load T24306 +:force x ===================================== testsuite/tests/ghci.debugger/scripts/T24306.stdout ===================================== @@ -0,0 +1 @@ +x = T 1 (MkA (##)) 2 ===================================== testsuite/tests/ghci.debugger/scripts/all.T ===================================== @@ -140,3 +140,4 @@ test('break030', ['break030.script'], ) test('T23057', [only_ghci, extra_hc_opts('-fno-break-points')], ghci_script, ['T23057.script']) +test('T24306', normal, ghci_script, ['T24306.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cdf84275eb1add5186d5b0485e31c36d4533f831...f58d5a8428f65eb35251b16a3faa1fc5de6ff26e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cdf84275eb1add5186d5b0485e31c36d4533f831...f58d5a8428f65eb35251b16a3faa1fc5de6ff26e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 13:35:41 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 05 Jan 2024 08:35:41 -0500 Subject: [Git][ghc/ghc][wip/dmdanal-annotation-state] DmdAnal: Explicit annotation state Message-ID: <659805ad62427_1126403a890a0159f@gitlab.mail> Sebastian Graf pushed to branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC Commits: 22123fac by Sebastian Graf at 2024-01-05T11:33:45+01:00 DmdAnal: Explicit annotation state - - - - - 5 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,23 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + -- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds) + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +441,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +490,65 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty') + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds + + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () - alt_ty3 + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +561,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +622,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +988,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1048,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1101,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1233,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1907,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1927,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1937,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -1968,16 +1954,16 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take threshold_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] - - get_dmd :: Id -> Demand - get_dmd bndr + arg_triples = + take threshold_arity $ + zipWith (\b dmd -> (idType b, NotMarkedStrict, add_bot_boxity dmd)) + (filter isId bndrs) + rhs_dmds + + add_bot_boxity :: Demand -> Demand + add_bot_boxity dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2034,19 +2020,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2151,64 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + -- annotation done in dmdAnalRhsSig + -- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2321,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2406,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2423,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2448,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2472,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2580,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2679,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad ( guard, zipWithM_ ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -432,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22123fac8c8af3deb5979a32509afee5d9273e9e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/22123fac8c8af3deb5979a32509afee5d9273e9e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 14:23:05 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Fri, 05 Jan 2024 09:23:05 -0500 Subject: [Git][ghc/ghc][wip/T19520] Remove VoidRep from PrimRep, introduce PrimOrVoidRep Message-ID: <659810c934977_1126404c4a3202521d@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T19520 at Glasgow Haskell Compiler / GHC Commits: fcb0a1de by Krzysztof Gogolewski at 2024-01-05T15:22:42+01:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 25 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.Demand import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) @@ -857,7 +857,8 @@ primOpSig op GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep + = ReturnsVoid + | ReturnsPrim PrimRep | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value @@ -867,8 +868,11 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) | isUnboxedTupleTyCon tc -> ReturnsTuple | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -61,7 +61,7 @@ make_constr_itbls interp profile cons = where mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + let rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Cmm.Utils( import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -97,7 +97,6 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +135,10 @@ primElemRepCmmType Word64ElemRep = b64 primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +155,8 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -126,8 +126,9 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, + isGcPtrRep, primRepSizeB, primRepSizeW64_B, primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, @@ -1532,17 +1533,18 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -} --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, +-- | A 'PrimRep' is an abstraction of a /non-void/ type. +-- (Use 'PrimRepOrVoidRep' if you want void types too.) +-- It contains information that the code generator needs +-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep -- Unpacking of sum types is only supported since 9.6.1 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value #else - | BoxedRep !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep !(Maybe Levity) -- ^ Boxed, heap value #endif | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -1560,6 +1562,9 @@ data PrimRep | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1580,58 +1585,52 @@ instance Outputable PrimElemRep where ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1676,7 +1675,6 @@ primRepSizeB platform = \case DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep -- | Like primRepSizeB but assumes pointers/words are 8 words wide. @@ -1699,7 +1697,6 @@ primRepSizeW64_B = \case DoubleRep -> dOUBLE_SIZE AddrRep -> 8 BoxedRep{} -> 8 - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeW64_B rep primElemRepSizeB :: Platform -> PrimElemRep -> Int ===================================== compiler/GHC/HsToCore/Foreign/Utils.hs ===================================== @@ -57,7 +57,7 @@ primTyDescChar :: Platform -> Type -> Char primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' ===================================== compiler/GHC/Stg/Lift/Analysis.hs ===================================== @@ -418,7 +418,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -382,8 +382,6 @@ lintStgAppReps fun args = do = match_args actual_reps_left expected_reps_left -- Check for void rep (empty list) - -- Note typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. | isVoidRep actual_rep && isVoidRep expected_rep = match_args actual_reps_left expected_reps_left ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.Stg.Syntax ( stgArgType, stgArgRep, stgArgRep1, + stgArgRepU, stgArgRep_maybe, stgCaseBndrInScope, @@ -80,7 +81,7 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -90,7 +91,7 @@ import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable @@ -177,10 +178,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -199,11 +200,17 @@ stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep_maybe :: StgArg -> Maybe [PrimRep] stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) --- | Assumes that the argument has one PrimRep, which holds after unarisation. +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -stgArgRep1 :: StgArg -> PrimRep +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep stgArgRep1 ty = typePrimRep1 (stgArgType ty) +-- | Assumes that the argument has exactly one PrimRep. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -373,6 +373,7 @@ STG programs after unarisation have these invariants: 2. No unboxed tuple binders. Tuples only appear in return position. 3. Binders and literals always have zero (for void arguments) or one PrimRep. + (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.) 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments. This means that it's safe to wrap `StgArg`s of DataCon applications with @@ -607,13 +608,12 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -814,7 +814,7 @@ mapSumIdBinders alt_bndr args rhs rho0 mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -860,7 +860,7 @@ mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -922,8 +922,8 @@ mkUbxSum dc ty_args args0 us castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= stgArgRep1 arg - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout @@ -529,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (stgArgRep1 e) + arg_ty e = primRepCmmType platform (stgArgRepU e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -540,12 +540,14 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - let non_void VoidRep = False - non_void _ = True + let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep + rep_to_maybe VoidRep = Nothing + rep_to_maybe (NVRep rep) = Just rep + ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map stgArgRep1 es) + (mapMaybe (rep_to_maybe . stgArgRep1) es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -928,7 +930,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . idPrimRep + let bndr_ty = primRepCmmType platform . idPrimRepU tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -944,7 +946,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ idPrimRep arg)] + , not (isZeroBitTy $ idType arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -1378,10 +1380,10 @@ generatePrimCall d s p target _mb_unit _result_ty args layoutNativeCall profile NativePrimCall 0 - (primRepCmmType platform . stgArgRep1) + (primRepCmmType platform . stgArgRepU) nv_args - prim_args_offsets = mapFst stgArgRep1 args_offsets + prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 @@ -1457,7 +1459,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- ArgRep of what was actually pushed. pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] pargs _ [] = return [] pargs d (aa@(StgVarArg a):az) | Just t <- tyConAppTyCon_maybe (idType a) @@ -1470,7 +1472,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) + return ((code, NVRep AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az return ((code_a, stgArgRep1 aa) : rest) @@ -1483,8 +1485,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x + | VoidRep:xs <- a_reps_pushed_r_to_l = reverse xs | otherwise = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" @@ -1494,10 +1495,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- d_after_args is the stack depth once the args are on. -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) + r_rep = maybe_getCCallReturnRep result_ty {- Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call @@ -1570,10 +1568,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- this is a V (tag). r_sizeW = repSizeWords platform r_rep d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) -- generate the marshalling code we're going to call @@ -1611,17 +1608,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) + `snocOL` RETURN (toArgRepOrV platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) = case r of - VoidRep -> FFIVoid IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> FFISInt8 @@ -1668,7 +1665,7 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- --- to Just IntRep +-- to NVRep IntRep -- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert @@ -1676,16 +1673,16 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- --- to Nothing +-- to VoidRep -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) in case typePrimRep r_ty of - [] -> Nothing - [rep] -> Just rep + [] -> VoidRep + [rep] -> NVRep rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2131,10 +2128,10 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -2171,7 +2168,7 @@ mkSlideW !n !ws atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (stgArgRep1 e) +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -253,8 +253,8 @@ cgDataCon mn data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) ] ===================================== compiler/GHC/StgToCmm/ArgRep.hs ===================================== @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ module GHC.StgToCmm.ArgRep ( import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -68,7 +68,6 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ toArgRep platform rep = case rep of 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ argRepSizeW platform = \case ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -382,7 +382,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -18,7 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -176,24 +176,27 @@ assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (stgArgRep1 arg', arg')) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -205,4 +205,4 @@ idToReg :: Platform -> NonVoid Id -> LocalReg -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -488,7 +488,7 @@ accurate update would complexify the implementation and doesn't seem worth it. -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -522,9 +522,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -330,8 +330,8 @@ getArgRepsAmodes args = do where getArgRepAmode platform arg = case stgArgRep1 arg of VoidRep -> return (V, Nothing) - rep -> do expr <- getArgAmode (NonVoid arg) - return (toArgRep platform rep, Just expr) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -438,7 +438,6 @@ mkVirtHeapOffsetsWithPadding -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -520,13 +519,13 @@ mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -52,7 +52,6 @@ cgLit (LitString s) = -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1720,7 +1720,7 @@ emitPrimOp cfg primop = -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do regs <- case result_info of - ReturnsPrim VoidRep -> pure [] + ReturnsVoid -> pure [] ReturnsPrim rep -> do reg <- newTemp (primRepCmmType platform rep) pure [reg] ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -615,7 +615,7 @@ tickySlowCall lf_info args = do tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform . stgArgRep1) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/StgToJS/Arg.hs ===================================== @@ -120,7 +120,7 @@ genStaticArg a = case a of Nothing -> reg Just expr -> unfloated expr where - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -162,7 +162,7 @@ genArg a = case a of where -- if our argument is a joinid, it can be an unboxed tuple r :: HasDebugCallStack => JSRep - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -351,7 +351,7 @@ genBody ctx startReg args e typ = do -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -20,6 +20,7 @@ module GHC.StgToJS.Utils , typeJSRep , unaryTypeJSRep , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType , primRepSize , mkArityTag @@ -196,10 +197,9 @@ typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep -unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut) +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep -primRepToJSRep VoidRep = VoidV primRepToJSRep (BoxedRep _) = PtrV primRepToJSRep IntRep = IntV primRepToJSRep Int8Rep = IntV @@ -216,6 +216,10 @@ primRepToJSRep FloatRep = DoubleV primRepToJSRep DoubleRep = DoubleV primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,7 +1525,6 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. - -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys -- And then get the actual size of the unpacked constructor. rep_size = sum $ map primRepSizeW64_B prim_reps ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -11,11 +11,11 @@ module GHC.Types.RepType isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type @@ -38,7 +38,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -80,15 +80,6 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty - -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts @@ -129,7 +120,10 @@ countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = (length (typePrimRep arg) `max` 1) + + countFunRepArgs (n - 1) res + -- If typePrimRep returns [] that means a void arg, + -- and we count 1 for that | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -308,7 +302,6 @@ repSlotTy reps = case reps of _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -391,8 +384,7 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -441,18 +433,37 @@ See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) + +For example: + typePrimRep Int# = [IntRep] + typePrimRep Int = [LiftedRep] + typePrimRep (# Int#, Int# #) = [IntRep,IntRep] + typePrimRep (# #) = [] + typePrimRep (State# s) = [] + +After the unariser, all identifiers have at most one PrimRep +(that is, the [PrimRep] for each identifier is empty or a singleton list). +More precisely: typePrimRep1 will succeed (not crash) on every binder +and argument type. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +Thus, we have -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +1. typePrimRep :: Type -> [PrimRep] + which returns the list + +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. typePrimRep1 :: Type -> PrimOrVoidRep + data PrimOrVoidRep = VoidRep | NVRep PrimRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1, +which have analogous preconditions. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -546,17 +557,22 @@ typePrimRep ty = kindPrimRep (text "typePrimRep" <+> typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -567,15 +583,6 @@ tyConPrimRep tc where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -603,8 +610,6 @@ kindPrimRep_maybe ki -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -617,8 +622,7 @@ runtimeRepPrimRep doc rr_ty -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -634,7 +638,6 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcb0a1de395021aa6609cd108a2ddd21ccdd7ba2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcb0a1de395021aa6609cd108a2ddd21ccdd7ba2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 17:01:48 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 05 Jan 2024 12:01:48 -0500 Subject: [Git][ghc/ghc][wip/dmdanal-annotation-state] 3 commits: CoreSubst: Retain evaluatedness of unstable unfoldings Message-ID: <659835fc6edb8_1126408b27958356ef@gitlab.mail> Sebastian Graf pushed to branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC Commits: 4e2508e1 by Sebastian Graf at 2024-01-05T18:01:18+01:00 CoreSubst: Retain evaluatedness of unstable unfoldings - - - - - 67caeb6e by Sebastian Graf at 2024-01-05T18:01:18+01:00 Freshen uniques before demand analysis - - - - - b67dc3df by Sebastian Graf at 2024-01-05T18:01:18+01:00 DmdAnal: Explicit annotation state - - - - - 13 changed files: - + compiler/GHC/Core/FreshenUniques.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst Changes: ===================================== compiler/GHC/Core/FreshenUniques.hs ===================================== @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} + +module GHC.Core.FreshenUniques ( freshenUniques ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.TyCo.Subst + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +import qualified Data.List as List +import Data.Traversable (for) + +type M a = ReaderT Subst (State InScopeSet) a + +-- | Gives fresh uniques to all 'Var's ocurring in terms of the 'CoreProgram'. +-- It works by bringing all 'Var's into scope at once through calls to +-- 'substBndr'. +freshenUniques :: CoreProgram -> CoreProgram +freshenUniques prog = evalState (runReaderT (freshenTopBinds prog) emptySubst) emptyInScopeSet + +freshenTopBinds :: [CoreBind] -> M [CoreBind] +freshenTopBinds binds = do + -- The scoping semantics of top-level bindings are quite surprising; + -- All bindings are brought into scope at the beginning. Hence they + -- mustn't shadow each other. + -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/19529 + let bs = bindersOfBinds binds + -- ... hence we bring them all into scope here, without substituting anything. + let in_scope = mkInScopeSet $ mkVarSet bs + lift $ put $! in_scope + -- And we can be sure that no shadowing has happened so far, hence the assert: + massertPpr (sizeVarSet (getInScopeVars in_scope) == length bs) + (hang (text "Non-unique top-level Id(s)!") 2 $ + ppr (filter (\grp -> length grp > 1) (List.group bs))) + local (`setInScope` in_scope) $ + traverse freshenTopBind binds + +freshenTopBind :: CoreBind -> M CoreBind +-- Binders are already fresh; see freshenTopBinds above +freshenTopBind (NonRec b rhs) = NonRec b <$!> freshenExpr rhs +freshenTopBind (Rec binds) = fmap Rec $ for binds $ \(b, rhs) -> do + !rhs' <- freshenExpr rhs + pure (b, rhs') + +-- | `wrapSubstFunM f ids k` wraps a `substBndrs`-like function `f` such that +-- +-- 1. The `InScopeSet` in the state of `M` is taken for the substitution of +-- the binders `ids`. +-- 2. The extended `Subst` is available in the continuation `k` +-- 3. (But after this function exits, the `Subst` is reset, reader-like, with +-- no trace of `ids`) +-- 4. After this function exits, the `InScopeSet` is still extended with `ids`. +wrapSubstFunM :: (Subst -> ids -> (Subst, ids)) -> ids -> (ids -> M r) -> M r +wrapSubstFunM f ids k = ReaderT $ \subst -> do + in_scope <- get + let (!subst', !ids') = f (subst `setInScope` in_scope) ids + put $! getSubstInScope subst' + runReaderT (k ids') subst' + +withSubstBndrM :: Var -> (Var -> M r) -> M r +withSubstBndrM = wrapSubstFunM substBndr + +withSubstBndrsM :: [Var] -> ([Var] -> M r) -> M r +withSubstBndrsM = wrapSubstFunM substBndrs + +withSubstRecBndrsM :: [Id] -> ([Id] -> M r) -> M r +withSubstRecBndrsM = wrapSubstFunM substRecBndrs + +-- | The binders of the `CoreBind` are \"in scope\" in the +-- continuation. +freshenLocalBind :: CoreBind -> (CoreBind -> M r) -> M r +freshenLocalBind (NonRec b rhs) k = do + !rhs' <- freshenExpr rhs + withSubstBndrM b $ \(!b') -> k $! NonRec b' rhs' +freshenLocalBind (Rec binds) k = do + let (bs, rhss) = unzip binds + withSubstRecBndrsM bs $ \(!bs') -> do + !rhss' <- traverse freshenExpr rhss + k $! Rec $! zip bs' rhss' + +freshenExpr :: CoreExpr -> M CoreExpr +-- Quite like substExpr, but we freshen binders unconditionally. +-- So maybe this is more like substExpr, if we had that +freshenExpr (Coercion co) = Coercion <$!> (substCo <$> ask <*> pure co) +freshenExpr (Type t) = Type <$!> (substTy <$> ask <*> pure t) +freshenExpr e at Lit{} = pure e +freshenExpr (Var v) = lookupIdSubst <$> ask <*> pure v +freshenExpr (Tick t e) = do + t <- substTickish <$> ask <*> pure t + Tick t <$!> freshenExpr e +freshenExpr (Cast e co) = do + co' <- substCo <$> ask <*> pure co + flip Cast co' <$!> freshenExpr e +freshenExpr (App f a) = do + !f' <- freshenExpr f + !a' <- freshenExpr a + pure $ App f' a' +freshenExpr (Lam b e) = withSubstBndrM b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Lam b' e' +freshenExpr (Let b e) = do + freshenLocalBind b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Let b' e' +freshenExpr (Case e b ty alts) = do + !e' <- freshenExpr e + withSubstBndrM b $ \(!b') -> do + !ty' <- substTy <$> ask <*> pure ty + let do_alt (Alt con bs e) = withSubstBndrsM bs $ \(!bs') -> + Alt con bs' <$!> freshenExpr e + !alts' <- traverse do_alt alts + pure $ Case e' b' ty' alts' ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,23 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + -- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds) + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +441,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +490,65 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty') + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds + + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () - alt_ty3 + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +561,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +622,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +988,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1048,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1101,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1233,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1907,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1927,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1937,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -1968,16 +1954,16 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take threshold_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] - - get_dmd :: Id -> Demand - get_dmd bndr + arg_triples = + take threshold_arity $ + zipWith (\b dmd -> (idType b, NotMarkedStrict, add_bot_boxity dmd)) + (filter isId bndrs) + rhs_dmds + + add_bot_boxity :: Demand -> Demand + add_bot_boxity dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2034,19 +2020,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2151,64 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + -- annotation done in dmdAnalRhsSig + -- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2321,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2406,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2423,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2448,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2472,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2580,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2679,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.FreshenUniques ( freshenUniques ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) @@ -148,7 +149,8 @@ getCoreToDo dflags hpt_rule_base extra_vars maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase) - | phase `elem` strictnessBefore dflags = CoreDoDemand False + | phase `elem` strictnessBefore dflags + = CoreDoPasses [CoreFreshenUniques, CoreDoDemand False] maybe_strictness_before _ = CoreDoNothing @@ -169,8 +171,8 @@ getCoreToDo dflags hpt_rule_base extra_vars simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter (initGentleSimplMode dflags) hpt_rule_base - dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] + dmd_cpr_ww = if ww_on then [CoreFreshenUniques,CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreFreshenUniques,CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] demand_analyser = (CoreDoPasses ( @@ -338,7 +340,8 @@ getCoreToDo dflags hpt_rule_base extra_vars -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) (CoreDoDemand False), + runWhen (strictness || late_dmd_anal) $ CoreDoPasses + [ CoreFreshenUniques, CoreDoDemand False ], maybe_rule_check FinalPhase, @@ -517,6 +520,9 @@ doCorePass pass guts = do CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} addLateCostCentresMG guts + CoreFreshenUniques -> {-# SCC "FreshenUniques" #-} + updateBinds freshenUniques + CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -65,6 +65,7 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep | CoreAddCallerCcs | CoreAddLateCcs + | CoreFreshenUniques instance Outputable CoreToDo where ppr (CoreDoSimplify _) = text "Simplifier" @@ -92,6 +93,7 @@ instance Outputable CoreToDo where ppr (CoreDoRuleCheck {}) = text "Rule check" ppr CoreDoNothing = text "CoreDoNothing" ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + ppr CoreFreshenUniques = text "CoreFreshenUniques" pprPassDetails :: CoreToDo -> SDoc pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -514,10 +514,10 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) (subst',bndrs') = substBndrs subst bndrs args' = map (substExpr subst') args -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src, uf_cache = cache }) -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work - = NoUnfolding + = if uf_is_value cache then evaldUnfolding else NoUnfolding | otherwise -- But keep a stable one! = seqExpr new_tmpl `seq` unf { uf_tmpl = new_tmpl } ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -83,6 +83,7 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreFreshenUniques = Just Opt_D_dump_freshen coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -118,6 +118,7 @@ data DumpFlag | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) | Opt_D_dump_call_arity | Opt_D_dump_exitify + | Opt_D_dump_freshen -- ^ FreshenUniques | Opt_D_dump_dmdanal | Opt_D_dump_dmd_signatures | Opt_D_dump_cpranal ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1461,6 +1461,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-freshen" + (setDumpFlag Opt_D_dump_freshen) , make_dep_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_dmdanal) "Use `-ddump-dmdanal` instead" ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad ( guard, zipWithM_ ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -333,6 +333,7 @@ Library GHC.Core.ConLike GHC.Core.DataCon GHC.Core.FamInstEnv + GHC.Core.FreshenUniques GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint @@ -431,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== docs/users_guide/debugging.rst ===================================== @@ -481,6 +481,13 @@ subexpression elimination pass. Dump static argument transformation pass output (see :ghc-flag:`-fstatic-argument-transformation`) +.. ghc-flag:: -ddump-freshen + :shortdesc: Dump output after freshening uniques + :type: dynamic + + Dump the Core after each run of FreshenUniques, which makes sure that each + binder's Unique is indeed globally unique. + .. ghc-flag:: -ddump-worker-wrapper :shortdesc: Dump worker-wrapper output :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22123fac8c8af3deb5979a32509afee5d9273e9e...b67dc3df2132554ec11b721946f85c25386b816e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/22123fac8c8af3deb5979a32509afee5d9273e9e...b67dc3df2132554ec11b721946f85c25386b816e You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 17:29:53 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 Jan 2024 12:29:53 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] 2 commits: Big refactor Message-ID: <65983c918eb42_11264099391b8387e7@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: f4e8ef68 by Simon Peyton Jones at 2024-01-05T17:28:36+00:00 Big refactor ..based on conversations with Vlad and Ricahrd Proper commit message yet to come... - - - - - 3557c651 by Simon Peyton Jones at 2024-01-05T17:29:21+00:00 Revert erroneous changes to error messages - - - - - 30 changed files: - compiler/GHC/Core/Make.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/ado/T16135.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d64c8207ebe1559c258d91d3c673ffdfc38a775...3557c651197e9a1617f27431acdd4565325e2613 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d64c8207ebe1559c258d91d3c673ffdfc38a775...3557c651197e9a1617f27431acdd4565325e2613 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 17:47:15 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 Jan 2024 12:47:15 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] Wibbles Message-ID: <659840a39cc11_112640a34bb1045061@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 8cb420ce by Simon Peyton Jones at 2024-01-05T17:46:58+00:00 Wibbles - - - - - 2 changed files: - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Utils/TcType.hs Changes: ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -179,7 +179,6 @@ tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) -- We begin with a special case for HsLam, in case the pushed-down type -- is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int --- See Note [Supporting type abstractions] tcPolyExpr e@(HsLam x lam_variant matches) res_ty = do { (wrap, matches') <- tcMatchLambda e lam_variant matches [] res_ty ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -238,7 +238,6 @@ import GHC.Utils.Panic import Data.IORef ( IORef ) import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition, nub, (\\) ) -import Data.Maybe ( mapMaybe ) {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8cb420cea7bede57fba5754a0dc4c042dcfad5e4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8cb420cea7bede57fba5754a0dc4c042dcfad5e4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 19:14:10 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 Jan 2024 14:14:10 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] Wibble Message-ID: <659855029eff9_112640c90f234593be@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 58d9f956 by Simon Peyton Jones at 2024-01-05T19:13:54+00:00 Wibble - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Bind.hs Changes: ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -818,6 +818,7 @@ checkMonomorphismRestriction mbis lbinds no_mr_name (MBI { mbi_sig = Just sig }) | TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig = case info of + TcPatSynSig {} -> Nothing -- Never happens TcCompleteSig (CSig { sig_bndr = bndr }) -> Just (idName bndr) TcPartialSig (PSig { psig_name = nm }) | null theta, isNothing wcx -> Nothing -- f :: _ -> _ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58d9f9561231bd60f834c3321aa86348cade2fbc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58d9f9561231bd60f834c3321aa86348cade2fbc You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 19:15:34 2024 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Fri, 05 Jan 2024 14:15:34 -0500 Subject: [Git][ghc/ghc][wip/fprof-overloaded] add -fprof-late-overloaded and -fprof-late-overloaded-calls Message-ID: <65985556522e_112640c9b9b94601a4@gitlab.mail> Finley McIlwaine pushed to branch wip/fprof-overloaded at Glasgow Haskell Compiler / GHC Commits: dc9303c2 by Finley McIlwaine at 2024-01-05T11:15:11-08:00 add -fprof-late-overloaded and -fprof-late-overloaded-calls * Refactor late cost centre insertion for extensibility * Add two more late cost centre insertion methods that add SCCs to overloaded top level bindings and call sites with dictionary arguments. * Some tests for the basic functionality of the new insertion methods - - - - - 26 changed files: - compiler/GHC/Core/LateCC.hs - + compiler/GHC/Core/LateCC/OverloadedCalls.hs - + compiler/GHC/Core/LateCC/TopLevelBinds.hs - + compiler/GHC/Core/LateCC/Types.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/ghc.cabal.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/profiling.rst - testsuite/tests/profiling/should_run/all.T - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample - + testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout - + testsuite/tests/profiling/should_run/scc001.prof copy.sample Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -1,164 +1,94 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TupleSections #-} - --- | Adds cost-centers after the core piple has run. +-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC - ( addLateCostCentresMG - , addLateCostCentresPgm - , addLateCostCentres -- Might be useful for API users - , Env(..) + ( -- * Inserting cost centres + addLateCostCentres -- Might be useful for API users + + -- * Helpers for defining insertion methods + , getCCFlavour + , insertCC + + -- * Types + , LateCCEnv(..) + , LateCCState(..) + , initLateCCState ) where -import Control.Applicative +import GHC.Prelude + import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict import qualified Data.Set as S -import GHC.Prelude +import GHC.Core +import GHC.Core.LateCC.Types +import GHC.Core.Utils +import GHC.Data.FastString import GHC.Types.CostCentre import GHC.Types.CostCentre.State -import GHC.Types.Name hiding (varName) +import GHC.Types.SrcLoc import GHC.Types.Tickish -import GHC.Unit.Module.ModGuts -import GHC.Types.Var -import GHC.Unit.Types -import GHC.Data.FastString -import GHC.Core -import GHC.Core.Opt.Monad -import GHC.Core.Utils (mkTick) -import GHC.Types.Id -import GHC.Driver.DynFlags - -import GHC.Utils.Logger -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Error (withTiming) -import GHC.Utils.Monad.State.Strict - - -{- Note [Collecting late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Usually cost centres defined by a module are collected -during tidy by collectCostCentres. However with `-fprof-late` -we insert cost centres after inlining. So we keep a list of -all the cost centres we inserted and combine that with the list -of cost centres found during tidy. - -To avoid overhead when using -fprof-inline there is a flag to stop -us from collecting them here when we run this pass before tidy. - -Note [Adding late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is very simple. For every top level binder -`f = rhs` we compile it as if the user had written -`f = {-# SCC f #-} rhs`. - -If we do this after unfoldings for `f` have been created this -doesn't impact core-level optimizations at all. If we do it -before the cost centre will be included in the unfolding and -might inhibit optimizations at the call site. For this reason -we provide flags for both approaches as they have different -tradeoffs. - -We also don't add a cost centre for any binder that is a constructor -worker or wrapper. These will never meaningfully enrich the resulting -profile so we improve efficiency by omitting those. --} - -addLateCostCentresMG :: ModGuts -> CoreM ModGuts -addLateCostCentresMG guts = do - dflags <- getDynFlags - let env :: Env - env = Env - { thisModule = mg_module guts - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = False -- See Note [Collecting late cost centres] - } - let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) - } - return guts' - -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentresPgm dflags logger mod binds = - withTiming logger - (text "LateCC"<+>brackets (ppr mod)) - (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do - let env = Env - { thisModule = mod - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = True -- See Note [Collecting late cost centres] - } - (binds', ccs, cc_state) = addLateCostCentres env binds - when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ - putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds')) - return (binds', ccs, cc_state) - -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, S.Set CostCentre, CostCentreState) -addLateCostCentres env binds = - let (binds', state) = runState (mapM (doBind env) binds) initLateCCState - in (binds', lcs_ccs state, lcs_state state) - - -doBind :: Env -> CoreBind -> M CoreBind -doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs -doBind env (Rec bs) = Rec <$> mapM doPair bs +-- | Insert cost centres into the 'CoreProgram' using the provided environment, +-- initial state, and insertion method. +addLateCostCentres + :: LateCCEnv + -- ^ Environment to run the insertion in + -> LateCCState s + -- ^ Initial state to run the insertion with + -> (CoreBind -> LateCCM s CoreBind) + -- ^ Insertion method + -> CoreProgram + -- ^ Bindings to consider + -> (CoreProgram, LateCCState s) +addLateCostCentres env state method binds = + runLateCC env state $ mapM method binds + +-- | Evaluate late cost centre insertion +runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s) +runLateCC env state = (`runState` state) . (`runReaderT` env) + +-- | The empty late cost centre insertion state +initLateCCState :: s -> LateCCState s +initLateCCState s = + LateCCState + { lateCCState_ccState = newCostCentreState + , lateCCState_ccs = mempty + , lateCCState_extra = s + } + +-- | Given the name of a cost centre, get its flavour +getCCFlavour :: FastString -> LateCCM s CCFlavour +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name where - doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr)) - doPair (b,rhs) = (b,) <$> doBndr env b rhs - -doBndr :: Env -> Id -> CoreExpr -> M CoreExpr -doBndr env bndr rhs - -- Cost centres on constructor workers are pretty much useless - -- so we don't emit them if we are looking at the rhs of a constructor - -- binding. - | Just _ <- isDataConId_maybe bndr = pure rhs - | otherwise = doBndr' env bndr rhs - - --- We want to put the cost centre below the lambda as we only care about executions of the RHS. -doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr -doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs -doBndr' env bndr rhs = do - let name = idName bndr - name_loc = nameSrcSpan name - cc_name = getOccFS name - count = countEntries env + getCCIndex' :: FastString -> LateCCM s CostCentreIndex + getCCIndex' name = do + cc_state <- lift $ gets lateCCState_ccState + let (index, cc_state') = getCCIndex name cc_state + lift . modify $ \s -> s { lateCCState_ccState = cc_state'} + return index + +-- | Insert a cost centre with the specified name and source span on the given +-- expression. The inserted cost centre will be appropriately tracked in the +-- late cost centre state. +insertCC + :: FastString + -- ^ Name of the cost centre to insert + -> SrcSpan + -- ^ Source location to associate with the cost centre + -> CoreExpr + -- ^ Expression to wrap in the cost centre + -> LateCCM s CoreExpr +insertCC cc_name cc_loc expr = do cc_flavour <- getCCFlavour cc_name - let cc_mod = thisModule env - bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc - note = ProfNote bndrCC count True - addCC env bndrCC - return $ mkTick note rhs - -data LateCCState = LateCCState - { lcs_state :: !CostCentreState - , lcs_ccs :: S.Set CostCentre - } -type M = State LateCCState - -initLateCCState :: LateCCState -initLateCCState = LateCCState newCostCentreState mempty - -getCCFlavour :: FastString -> M CCFlavour -getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name - -getCCIndex' :: FastString -> M CostCentreIndex -getCCIndex' name = do - state <- get - let (index,cc_state') = getCCIndex name (lcs_state state) - put (state { lcs_state = cc_state'}) - return index - -addCC :: Env -> CostCentre -> M () -addCC !env cc = do - state <- get - when (collectCCs env) $ do - let ccs' = S.insert cc (lcs_ccs state) - put (state { lcs_ccs = ccs'}) - -data Env = Env - { thisModule :: !Module - , countEntries:: !Bool - , collectCCs :: !Bool - } - + env <- ask + let + cc_mod = lateCCEnv_module env + cc = NormalCC cc_flavour cc_name cc_mod cc_loc + note = ProfNote cc (lateCCEnv_countEntries env) True + when (lateCCEnv_collectCCs env) $ do + lift . modify $ \s -> + s { lateCCState_ccs = S.insert cc (lateCCState_ccs s) + } + return $ mkTick note expr ===================================== compiler/GHC/Core/LateCC/OverloadedCalls.hs ===================================== @@ -0,0 +1,176 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Core.LateCC.OverloadedCalls + ( overloadedCallsCC + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified GHC.Data.Strict as Strict + +import GHC.Data.FastString +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Make +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Var +import GHC.Utils.Outputable + +type S = Strict.Maybe SrcSpan + +-- | Insert cost centres on function applications with dictionary arguments. The +-- source locations attached to the cost centres is approximated based on the +-- "closest" source note encountered in the traversal. +overloadedCallsCC :: CoreBind -> LateCCM S CoreBind +overloadedCallsCC = + processBind + where + processBind :: CoreBind -> LateCCM S CoreBind + processBind core_bind = + case core_bind of + NonRec b e -> + NonRec b <$> processExpr e + Rec es -> + Rec <$> mapM (\(b,e) -> (b,) <$> processExpr e) es + + processExpr :: CoreExpr -> LateCCM S CoreExpr + processExpr expr = + case expr of + -- The case we care about: Application + app at App{} -> do + -- Here we have some application like `f v1 ... vN`, where v1 ... vN + -- should be the function's type arguments followed by the value + -- arguments. To determine if the `f` is an overloaded function (i.e. not + -- specialised), we check if any of the arguments v1 ... vN are + -- dictionaries. + let + (f, xs) = collectArgs app + resultTy = applyTypeToArgs empty (exprType f) xs + + -- Recursively process the arguments first for no particular reason + args <- mapM processExpr xs + let app' = mkCoreApps f args + + if + -- Check if any of the arguments are dictionaries + any isDictExpr args + + -- Avoid instrumenting dictionary functions, which may be + -- overloaded if there are superclasses, by checking if the result + -- type of the function is a dictionary type. + && not (isDictTy resultTy) + + -- Avoid instrumenting constraint selectors like eq_sel + && (typeTypeOrConstraint resultTy /= ConstraintLike) + + -- Avoid instrumenting join points + && not (isJoinVarExpr f) + then do + -- Extract a name and source location from the function being + -- applied + let + cc_name :: FastString + cc_name = + fsLit $ maybe "" getOccString (exprName app) + + cc_srcspan <- + fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $ + lift $ gets lateCCState_extra + + insertCC cc_name cc_srcspan app' + else + return app' + + -- For recursive constructors of Expr, we traverse the nested Exprs + Lam b e -> + mkCoreLams [b] <$> processExpr e + Let b e -> + mkCoreLet <$> processBind b <*> processExpr e + Case e b t alts -> + Case + <$> processExpr e + <*> pure b + <*> pure t + <*> mapM processAlt alts + Cast e co -> + mkCast <$> processExpr e <*> pure co + Tick t e -> do + trackSourceNote t $ + mkTick t <$> processExpr e + + -- For non-recursive constructors of Expr, we do nothing + x -> return x + + processAlt :: CoreAlt -> LateCCM S CoreAlt + processAlt (Alt c bs e) = Alt c bs <$> processExpr e + + trackSourceNote :: CoreTickish -> LateCCM S a -> LateCCM S a + trackSourceNote tick act = + case tick of + SourceNote rss _ -> do + -- Prefer source notes from the current file + in_current_file <- + maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$> + asks lateCCEnv_file + if not in_current_file then + act + else do + loc <- lift $ gets lateCCState_extra + lift . modify $ \s -> + s { lateCCState_extra = + Strict.Just $ RealSrcSpan rss mempty + } + x <- act + lift . modify $ \s -> + s { lateCCState_extra = loc + } + return x + _ -> + act + + -- Utility functions + + -- Extract a Name from an expression. If it is an application, attempt to + -- extract a name from the applied function. If the expression is a + -- variable, return the Name of the variable. If the expression is a tick, + -- attempt to extract a Name from the expression held in the tick. Otherwise + -- return Nothing. + exprName :: CoreExpr -> Maybe Name + exprName = + \case + App f _ -> + exprName f + Var f -> + Just (idName f) + Tick _ e -> + exprName e + _ -> + Nothing + + -- Determine whether an expression is a dictionary + isDictExpr :: CoreExpr -> Bool + isDictExpr = + maybe False isDictTy . exprType' + where + exprType' :: CoreExpr -> Maybe Type + exprType' = \case + Type{} -> Nothing + expr -> Just $ exprType expr + + -- Determine whether an expression is a join variable + isJoinVarExpr :: CoreExpr -> Bool + isJoinVarExpr = + \case + Var var -> isJoinId var + _ -> False \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/TopLevelBinds.hs ===================================== @@ -0,0 +1,105 @@ +{-# LANGUAGE TupleSections #-} +module GHC.Core.LateCC.TopLevelBinds where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.LateCC +import GHC.Core.LateCC.Types +import GHC.Core.Opt.Monad +import GHC.Driver.DynFlags +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module.ModGuts + +{- Note [Collecting late cost centres] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usually cost centres defined by a module are collected +during tidy by collectCostCentres. However with `-fprof-late` +we insert cost centres after inlining. So we keep a list of +all the cost centres we inserted and combine that with the list +of cost centres found during tidy. + +To avoid overhead when using -fprof-inline there is a flag to stop +us from collecting them here when we run this pass before tidy. + +Note [Adding late cost centres to top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is very simple. For every top level binder +`f = rhs` we compile it as if the user had written +`f = {-# SCC f #-} rhs`. + +If we do this after unfoldings for `f` have been created this +doesn't impact core-level optimizations at all. If we do it +before the cost centre will be included in the unfolding and +might inhibit optimizations at the call site. For this reason +we provide flags for both approaches as they have different +tradeoffs. + +We also don't add a cost centre for any binder that is a constructor +worker or wrapper. These will never meaningfully enrich the resulting +profile so we improve efficiency by omitting those. + +-} + +-- | Add late cost centres directly to the 'ModGuts'. This is used inside the +-- core pipeline with the -fprof-late-inline flag. It should not be used after +-- tidy, since it does not manually track inserted cost centers. See +-- Note [Collecting late cost centres]. +topLevelBindsCCMG :: ModGuts -> CoreM ModGuts +topLevelBindsCCMG guts = do + dflags <- getDynFlags + let + env = + LateCCEnv + { lateCCEnv_module = mg_module guts + + -- We don't use this for topLevelBindsCC, so Nothing is okay + , lateCCEnv_file = Nothing + + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = False + } + guts' = + guts + { mg_binds = + fst + ( addLateCostCentres + env + (initLateCCState ()) + (topLevelBindsCC (const True)) + (mg_binds guts) + ) + } + return guts' + +-- | Insert cost centres on top level bindings in the module, depending on +-- whether or not they satisfy the given predicate. +topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind +topLevelBindsCC pred core_bind = + case core_bind of + NonRec b rhs -> + NonRec b <$> doBndr b rhs + Rec bs -> + Rec <$> mapM doPair bs + where + doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr)) + doPair (b,rhs) = (b,) <$> doBndr b rhs + + doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr + doBndr bndr rhs + -- Cost centres on constructor workers are pretty much useless + -- so we don't emit them if we are looking at the rhs of a constructor + -- binding. + | Just _ <- isDataConId_maybe bndr = pure rhs + | otherwise = if pred rhs then addCC bndr rhs else pure rhs + + -- We want to put the cost centre below the lambda as we only care about + -- executions of the RHS. + addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs + addCC bndr rhs = do + let name = idName bndr + cc_loc = nameSrcSpan name + cc_name = getOccFS name + insertCC cc_name cc_loc rhs \ No newline at end of file ===================================== compiler/GHC/Core/LateCC/Types.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DerivingStrategies #-} +module GHC.Core.LateCC.Types where + +import GHC.Prelude + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Unit.Types + +-- | Late cost centre insertion environment +data LateCCEnv = LateCCEnv + { lateCCEnv_module :: !Module + -- ^ Current module + , lateCCEnv_file :: Maybe FastString + -- ^ Current file, if we have one + , lateCCEnv_countEntries:: !Bool + -- ^ Whether the inserted cost centers should count entries + , lateCCEnv_collectCCs :: !Bool + -- ^ Whether to collect the cost centres we insert. See + -- Note [Collecting late cost centres] + } + +-- | Late cost centre insertion state, indexed by some extra state type that an +-- insertion method may require. +data LateCCState s = LateCCState + { lateCCState_ccs :: !(S.Set CostCentre) + -- ^ Cost centres that have been inserted + , lateCCState_ccState :: !CostCentreState + -- ^ Per-module state tracking for cost centre indices + , lateCCState_extra :: !s + } + +-- | Late cost centre insertion monad +type LateCCM s = ReaderT LateCCEnv (State (LateCCState s)) ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -43,7 +43,7 @@ import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) -import GHC.Core.LateCC (addLateCostCentresMG) +import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -515,7 +515,7 @@ doCorePass pass guts = do addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} - addLateCostCentresMG guts + topLevelBindsCCMG guts CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -335,6 +335,8 @@ data GeneralFlag | Opt_ProfCountEntries | Opt_ProfLateInlineCcs | Opt_ProfLateCcs + | Opt_ProfLateOverloadedCcs + | Opt_ProfLateoverloadedCallsCCs | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations -- misc opts ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -175,7 +175,6 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) import GHC.Core import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) -import GHC.Core.Type ( Type, Kind ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike import GHC.Core.Opt.Pipeline @@ -185,7 +184,9 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Rules import GHC.Core.Stats -import GHC.Core.LateCC (addLateCostCentresPgm) +import GHC.Core.LateCC +import GHC.Core.LateCC.TopLevelBinds +import GHC.Core.LateCC.OverloadedCalls import GHC.CoreToStg.Prep @@ -197,6 +198,7 @@ import GHC.Parser.Lexer as Lexer import GHC.Tc.Module import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax @@ -266,6 +268,7 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict import qualified GHC.SysTools import GHC.SysTools (initSysTools) @@ -297,7 +300,6 @@ import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) -import GHC.Types.CostCentre.State (newCostCentreState) {- ********************************************************************** @@ -1791,22 +1793,70 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------- - -- Insert late cost centres if enabled. + -- Insert late cost centres on top level bindings if enabled. -- If `-fprof-late-inline` is enabled we can skip this, as it will have added -- a superset of cost centres we would add here already. - (late_cc_binds, late_local_ccs, cc_state) <- - if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then - withTiming - logger - (text "LateCCs"<+>brackets (ppr this_mod)) - (const ()) - $ {-# SCC lateCC #-} do - (binds, late_ccs, cc_state) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs ), cc_state) - else - return (core_binds, local_ccs, newCostCentreState) + -- If `-fprof-late-overloaded` is enabled, only add CCs to bindings for + -- overloaded functions. + let + topLevelCCPred :: CoreExpr -> Bool + topLevelCCPred = + if gopt Opt_ProfLateOverloadedCcs dflags then + isOverloadedTy . exprType + else + const True + + doLateTopLevelCcs :: Bool + doLateTopLevelCcs = + (gopt Opt_ProfLateCcs dflags || gopt Opt_ProfLateOverloadedCcs dflags) && not (gopt Opt_ProfLateInlineCcs dflags) + + lateCCEnv :: LateCCEnv + lateCCEnv = + LateCCEnv + { lateCCEnv_module = this_mod + , lateCCEnv_file = fsLit <$> ml_hs_file location + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = True + } + + (top_level_cc_binds, top_level_late_cc_state) <- + if doLateTopLevelCcs then do + withTiming + logger + (text "LateTopLevelCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateTopLevelCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (initLateCCState ()) + (topLevelBindsCC topLevelCCPred) + core_binds + else + return (core_binds, initLateCCState ()) + + (late_cc_binds, late_cc_state) <- + if gopt Opt_ProfLateoverloadedCallsCCs dflags then + withTiming + logger + (text "LateOverloadedCallsCCs"<+>brackets (ppr this_mod)) + (\(binds, late_cc_state) -> binds `seqList` (late_cc_state `seq` ())) + $ {-# SCC lateoverloadedCallsCCs #-} do + pure $ + addLateCostCentres + lateCCEnv + (top_level_late_cc_state { lateCCState_extra = Strict.Nothing }) + overloadedCallsCC + top_level_cc_binds + else + return + ( top_level_cc_binds + , top_level_late_cc_state { lateCCState_extra = Strict.Nothing } + ) + + when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ + putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds)) ------------------- -- Run late plugins @@ -1820,7 +1870,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_hpc_info = hpc_info, cg_spt_entries = spt_entries, cg_binds = late_binds, - cg_ccs = late_local_ccs' + cg_ccs = late_local_ccs } , _ ) <- @@ -1833,9 +1883,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do (($ hsc_env) . latePlugin) ( cgguts { cg_binds = late_cc_binds - , cg_ccs = late_local_ccs + , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs } - , cc_state + , lateCCState_ccState late_cc_state ) let @@ -1876,7 +1926,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do let (stg_binds,_stg_deps) = unzip stg_binds_with_deps let cost_centre_info = - (late_local_ccs' ++ caf_ccs, caf_cc_stacks) + (late_local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags prof_init | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2431,6 +2431,8 @@ fFlagsDeps = [ flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "prof-late" Opt_ProfLateCcs, + flagSpec "prof-late-overloaded" Opt_ProfLateOverloadedCcs, + flagSpec "prof-late-overloaded-calls" Opt_ProfLateoverloadedCallsCCs, flagSpec "prof-manual" Opt_ProfManualCcs, flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, flagSpec "regs-graph" Opt_RegsGraph, @@ -3748,6 +3750,10 @@ needSourceNotes :: DynFlags -> Bool needSourceNotes dflags = debugLevel dflags > 0 || gopt Opt_InfoTableMap dflags + -- Source ticks are used to approximate the location of + -- overloaded call cost centers + || gopt Opt_ProfLateoverloadedCallsCCs dflags + -- ----------------------------------------------------------------------------- -- Linker/compiler information ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -1883,7 +1883,7 @@ isRhoExpTy (Infer {}) = True isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods +-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af ===================================== compiler/ghc.cabal.in ===================================== @@ -338,6 +338,9 @@ Library GHC.Core.Lint GHC.Core.Lint.Interactive GHC.Core.LateCC + GHC.Core.LateCC.Types + GHC.Core.LateCC.TopLevelBinds + GHC.Core.LateCC.OverloadedCalls GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -129,6 +129,15 @@ Compiler - Late plugins have been added. These are plugins which can access and/or modify the core of a module after optimization and after interface creation. See :ghc-ticket:`24254`. +- The :ghc-flag:`-fprof-late-overloaded` flag has been introduced. It causes + cost centres to be added to *overloaded* top level bindings, unlike + :ghc-flag:`-fprof-late` which adds cost centres to all top level bindings. + +- The :ghc-flag:`-fprof-late-overloaded-calls` flag has been introduced. It + causes cost centres to be inserted at call sites including instance dictionary + arguments. This may be preferred over :ghc-flag:`-fprof-late-overloaded` since + it may reveal whether imported functions are called overloaded. + GHCi ~~~~ ===================================== docs/users_guide/profiling.rst ===================================== @@ -518,6 +518,42 @@ of your profiled program will be different to that of the unprofiled one. You can try this mode if :ghc-flag:`-fprof-late` results in a profile that's too hard to interpret. +.. ghc-flag:: -fprof-late-overloaded + :shortdesc: Auto-add ``SCC``\\ s to all top level overloaded bindings *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all *overloaded* top level bindings + late in the compilation pipeline after the optimizer has run and unfoldings + have been created. This means these cost centres will not interfere with + core-level optimizations and the resulting profile will be closer to the + performance profile of an optimized non-profiled executable. + + This flag can help determine which top level bindings encountered during a + program's execution are still overloaded after inlining and specialization. + +.. ghc-flag:: -fprof-late-overloaded-calls + :shortdesc: Auto-add ``SCC``\\ s to all call sites that include dictionary arguments *after* the core pipeline has run. + :type: dynamic + :reverse: -fno-prof-late-overloaded-calls + :category: + + :since: 9.10.1 + + Adds an automatic ``SCC`` annotation to all call sites that include + dictionary arguments late in the compilation pipeline after the optimizer + has run and unfoldings have been created. This means these cost centres will + not interfere with core-level optimizations and the resulting profile will + be closer to the performance profile of an optimized non-profiled + executable. + + This flag is potentially more useful than :ghc-flag:`-fprof-late-overloaded` + since it will add ``SCC`` annotations to call sites of imported functions + that are overloaded. + .. ghc-flag:: -fprof-cafs :shortdesc: Auto-add ``SCC``\\ s to all CAFs :type: dynamic ===================================== testsuite/tests/profiling/should_run/all.T ===================================== @@ -196,3 +196,30 @@ test('ignore_scc', [], compile_and_run, ['-fno-prof-manual']) test('T21446', [], makefile_test, ['T21446']) + + +test('scc-prof-overloaded001', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded002', + [], + compile_and_run, + ['-fno-prof-auto -fno-full-laziness -fprof-late-overloaded'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls001', + [], + compile_and_run, + # Need optimizations to get rid of unwanted overloaded calls + ['-O -fno-prof-auto -fno-full-laziness -fprof-late-overloaded-calls'] # See Note [consistent stacks] +) + +test('scc-prof-overloaded-calls002', + [], + compile_and_run, + # Need optimizations to get rid of unwanted overloaded calls + ['-O -fno-prof-auto -fprof-late-overloaded-calls'] +) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.prof.sample ===================================== @@ -0,0 +1,26 @@ + Thu Jan 4 11:49 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,320 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded-calls001.hs:24:1-31 256 1 0.0 0.3 0.0 0.8 + f Main scc-prof-overloaded-calls001.hs:18:1-18 257 1 0.0 0.6 0.0 0.6 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.prof.sample ===================================== @@ -0,0 +1,31 @@ + Fri Jan 5 11:06 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded-calls002 +RTS -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 59,152 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 34.8 +CAF GHC.IO.Handle.FD 0.0 58.7 +CAF GHC.IO.Encoding 0.0 4.1 +CAF GHC.Conc.Signal 0.0 1.1 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 34.8 0.0 100.0 + CAF Main 255 0 0.0 0.6 0.0 0.9 + f Main scc-prof-overloaded-calls002.hs:52:1-25 262 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:48:1-25 261 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:44:1-25 260 1 0.0 0.1 0.0 0.1 + f Main scc-prof-overloaded-calls002.hs:40:1-25 259 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:36:1-25 258 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:32:1-25 257 1 0.0 0.0 0.0 0.0 + f Main scc-prof-overloaded-calls002.hs:28:1-25 256 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 238 0 0.0 1.1 0.0 1.1 + CAF GHC.IO.Encoding 219 0 0.0 4.1 0.0 4.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.3 0.0 0.3 + CAF GHC.IO.Handle.FD 208 0 0.0 58.7 0.0 58.7 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded-calls002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.hs ===================================== @@ -0,0 +1,24 @@ +-- Running this program should result in two calls to overloaded functions: One +-- with the $fShowX dictionary, the next with the $fShowList dictionary +-- constructor for X. +-- +-- Note that although the `$fShowList` dictionary constructor is itself +-- overloaded, it should not get an SCC since we avoid instrumenting overloaded +-- calls that result in dictionaries. +-- +-- With just -fprof-late-overloaded, only `invoke` should get an SCC, since it +-- is the only overloaded top level binding. With +-- `-fprof-late-overloaded-calls`, the calls to both `invoke` and `f` (in the +-- body of invoke) should get SCCs. + +module Main where + +{-# NOINLINE invoke #-} +invoke :: Show a => (Show [a] => [a] -> String) -> a -> String +invoke f x = f [x] + +data X = X + deriving Show + +main :: IO () +main = putStrLn (invoke show X) ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.prof.sample ===================================== @@ -0,0 +1,25 @@ + Thu Jan 4 11:26 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 48,304 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 20.5 +CAF GHC.IO.Handle.FD 0.0 71.9 +CAF GHC.IO.Encoding 0.0 5.1 +CAF GHC.Conc.Signal 0.0 1.3 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 20.5 0.0 100.0 + CAF Main 255 0 0.0 0.0 0.0 0.8 + invoke Main scc-prof-overloaded001.hs:18:1-6 256 1 0.0 0.8 0.0 0.8 + CAF GHC.Conc.Signal 238 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 219 0 0.0 5.1 0.0 5.1 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 71.9 0.0 71.9 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded001.stdout ===================================== @@ -0,0 +1 @@ +[X] ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.hs ===================================== @@ -0,0 +1,65 @@ +-- Running this program should result in seven calls to overloaded functions +-- with increasing numbers of dictionary arguments. +-- +-- With just -fprof-late-overloaded, no SCCs should be added, since none of the +-- overloaded functions are top level. With `-fprof-late-overloaded-calls`, all +-- seven calls should get *distinct* SCCs with separate source locations even +-- though the overloaded functions share an OccName (`f`). + +module Main where + +data X = X + +instance Show X where +instance Num X where +instance Eq X where +instance Enum X where +instance Ord X where +instance Real X where +instance Integral X where + +-- No overloaded call +{-# NOINLINE invoke0 #-} +invoke0 :: (forall a. a -> a -> String) -> X -> String +invoke0 f val = f val val + +{-# NOINLINE invoke1 #-} +invoke1 :: (forall a. Show a => a -> a -> String) -> X -> String +invoke1 f val = f val val + +{-# NOINLINE invoke2 #-} +invoke2 :: (forall a. (Show a, Num a) => a -> a -> String) -> X -> String +invoke2 f val = f val val + +{-# NOINLINE invoke3 #-} +invoke3 :: (forall a. (Show a, Num a, Eq a) => a -> a -> String) -> X -> String +invoke3 f val = f val val + +{-# NOINLINE invoke4 #-} +invoke4 :: (forall a. (Show a, Num a, Eq a, Enum a) => a -> a -> String) -> X -> String +invoke4 f val = f val val + +{-# NOINLINE invoke5 #-} +invoke5 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a) => a -> a -> String) -> X -> String +invoke5 f val = f val val + +{-# NOINLINE invoke6 #-} +invoke6 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a) => a -> a -> String) -> X -> String +invoke6 f val = f val val + +{-# NOINLINE invoke7 #-} +invoke7 :: (forall a. (Show a, Num a, Eq a, Enum a, Ord a, Real a, Integral a) => a -> a -> String) -> X -> String +invoke7 f val = f val val + +main :: IO () +main = do + putStrLn $ invoke0 (\_ _ -> s) X + putStrLn $ invoke1 (\_ _ -> s) X + putStrLn $ invoke2 (\_ _ -> s) X + putStrLn $ invoke3 (\_ _ -> s) X + putStrLn $ invoke4 (\_ _ -> s) X + putStrLn $ invoke5 (\_ _ -> s) X + putStrLn $ invoke6 (\_ _ -> s) X + putStrLn $ invoke7 (\_ _ -> s) X + where + s = "wibbly" ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.prof.sample ===================================== @@ -0,0 +1,23 @@ + Thu Jan 4 11:55 2024 Time and Allocation Profiling Report (Final) + + scc-prof-overloaded002 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 56,472 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 32.7 +CAF GHC.IO.Handle.FD 0.0 61.5 +CAF GHC.IO.Encoding 0.0 4.3 +CAF GHC.Conc.Signal 0.0 1.1 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 128 0 0.0 32.7 0.0 100.0 + CAF GHC.Conc.Signal 238 0 0.0 1.1 0.0 1.1 + CAF GHC.IO.Encoding 219 0 0.0 4.3 0.0 4.3 + CAF GHC.IO.Encoding.Iconv 217 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 208 0 0.0 61.5 0.0 61.5 ===================================== testsuite/tests/profiling/should_run/scc-prof-overloaded002.stdout ===================================== @@ -0,0 +1,8 @@ +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly +wibbly ===================================== testsuite/tests/profiling/should_run/scc001.prof copy.sample ===================================== @@ -0,0 +1,33 @@ + Wed Mar 29 06:17 2017 Time and Allocation Profiling Report (Final) + + scc001 +RTS -hc -p -RTS + + total time = 0.00 secs (0 ticks @ 1000 us, 1 processor) + total alloc = 50,856 bytes (excludes profiling overheads) + +COST CENTRE MODULE SRC %time %alloc + +MAIN MAIN 0.0 1.6 +CAF GHC.IO.Handle.FD 0.0 68.3 +CAF GHC.IO.Encoding 0.0 5.4 +CAF GHC.Conc.Signal 0.0 1.3 +main Main scc001.hs:(5,1)-(7,23) 0.0 22.2 + + + individual inherited +COST CENTRE MODULE SRC no. entries %time %alloc %time %alloc + +MAIN MAIN 111 0 0.0 1.6 0.0 100.0 + CAF Main 221 0 0.0 0.0 0.0 0.6 + (...) Main scc001.hs:16:1-16 227 1 0.0 0.0 0.0 0.0 + main Main scc001.hs:(5,1)-(7,23) 222 1 0.0 0.5 0.0 0.5 + h Main scc001.hs:16:1-16 226 1 0.0 0.0 0.0 0.0 + f Main scc001.hs:10:1-7 224 1 0.0 0.0 0.0 0.0 + g Main scc001.hs:13:1-7 225 1 0.0 0.0 0.0 0.0 + CAF GHC.Conc.Signal 216 0 0.0 1.3 0.0 1.3 + CAF GHC.IO.Encoding 206 0 0.0 5.4 0.0 5.4 + CAF GHC.IO.Encoding.Iconv 204 0 0.0 0.4 0.0 0.4 + CAF GHC.IO.Handle.FD 196 0 0.0 68.3 0.0 68.3 + CAF GHC.IO.Handle.Text 194 0 0.0 0.2 0.0 0.2 + CAF GHC.Show 179 0 0.0 0.6 0.0 0.6 + main Main scc001.hs:(5,1)-(7,23) 223 0 0.0 21.7 0.0 21.7 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc9303c210d52e5061dc97724603e450756a265b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc9303c210d52e5061dc97724603e450756a265b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Fri Jan 5 22:30:15 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 05 Jan 2024 17:30:15 -0500 Subject: [Git][ghc/ghc][wip/dmdanal-annotation-state] 2 commits: Freshen uniques before demand analysis Message-ID: <659882f785048_11264011937ef061242@gitlab.mail> Sebastian Graf pushed to branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC Commits: 1fe284c7 by Sebastian Graf at 2024-01-05T23:29:47+01:00 Freshen uniques before demand analysis - - - - - 8d699a6a by Sebastian Graf at 2024-01-05T23:29:47+01:00 DmdAnal: Explicit annotation state - - - - - 13 changed files: - + compiler/GHC/Core/FreshenUniques.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst Changes: ===================================== compiler/GHC/Core/FreshenUniques.hs ===================================== @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} + +module GHC.Core.FreshenUniques ( freshenUniques ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.TyCo.Subst + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +import qualified Data.List as List +import Data.Traversable (for) + +type M a = ReaderT Subst (State InScopeSet) a + +-- | Gives fresh uniques to all 'Var's ocurring in terms of the 'CoreProgram'. +-- It works by bringing all 'Var's into scope at once through calls to +-- 'substBndr'. +freshenUniques :: CoreProgram -> CoreProgram +freshenUniques prog = evalState (runReaderT (freshenTopBinds prog) emptySubst) emptyInScopeSet + +freshenTopBinds :: [CoreBind] -> M [CoreBind] +freshenTopBinds binds = do + -- The scoping semantics of top-level bindings are quite surprising; + -- All bindings are brought into scope at the beginning. Hence they + -- mustn't shadow each other. + -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/19529 + let bs = bindersOfBinds binds + -- ... hence we bring them all into scope here, without substituting anything. + let in_scope = mkInScopeSet $ mkVarSet bs + lift $ put $! in_scope + -- And we can be sure that no shadowing has happened so far, hence the assert: + massertPpr (sizeVarSet (getInScopeVars in_scope) == length bs) + (hang (text "Non-unique top-level Id(s)!") 2 $ + ppr (filter (\grp -> length grp > 1) (List.group bs))) + local (`setInScope` in_scope) $ + traverse freshenTopBind binds + +freshenTopBind :: CoreBind -> M CoreBind +-- Binders are already fresh; see freshenTopBinds above +freshenTopBind (NonRec b rhs) = NonRec b <$!> freshenExpr rhs +freshenTopBind (Rec binds) = fmap Rec $ for binds $ \(b, rhs) -> do + !rhs' <- freshenExpr rhs + pure (b, rhs') + +-- | `wrapSubstFunM f ids k` wraps a `substBndrs`-like function `f` such that +-- +-- 1. The `InScopeSet` in the state of `M` is taken for the substitution of +-- the binders `ids`. +-- 2. The extended `Subst` is available in the continuation `k` +-- 3. (But after this function exits, the `Subst` is reset, reader-like, with +-- no trace of `ids`) +-- 4. After this function exits, the `InScopeSet` is still extended with `ids`. +wrapSubstFunM :: (Subst -> ids -> (Subst, ids)) -> ids -> (ids -> M r) -> M r +wrapSubstFunM f ids k = ReaderT $ \subst -> do + in_scope <- get + let (!subst', !ids') = f (subst `setInScope` in_scope) ids + put $! getSubstInScope subst' + runReaderT (k ids') subst' + +withSubstBndrM :: Var -> (Var -> M r) -> M r +withSubstBndrM = wrapSubstFunM substBndr + +withSubstBndrsM :: [Var] -> ([Var] -> M r) -> M r +withSubstBndrsM = wrapSubstFunM substBndrs + +withSubstRecBndrsM :: [Id] -> ([Id] -> M r) -> M r +withSubstRecBndrsM = wrapSubstFunM substRecBndrs + +-- | The binders of the `CoreBind` are \"in scope\" in the +-- continuation. +freshenLocalBind :: CoreBind -> (CoreBind -> M r) -> M r +freshenLocalBind (NonRec b rhs) k = do + !rhs' <- freshenExpr rhs + withSubstBndrM b $ \(!b') -> k $! NonRec b' rhs' +freshenLocalBind (Rec binds) k = do + let (bs, rhss) = unzip binds + withSubstRecBndrsM bs $ \(!bs') -> do + !rhss' <- traverse freshenExpr rhss + k $! Rec $! zip bs' rhss' + +freshenExpr :: CoreExpr -> M CoreExpr +-- Quite like substExpr, but we freshen binders unconditionally. +-- So maybe this is more like substExpr, if we had that +freshenExpr (Coercion co) = Coercion <$!> (substCo <$> ask <*> pure co) +freshenExpr (Type t) = Type <$!> (substTy <$> ask <*> pure t) +freshenExpr e at Lit{} = pure e +freshenExpr (Var v) = lookupIdSubst <$> ask <*> pure v +freshenExpr (Tick t e) = do + t <- substTickish <$> ask <*> pure t + Tick t <$!> freshenExpr e +freshenExpr (Cast e co) = do + co' <- substCo <$> ask <*> pure co + flip Cast co' <$!> freshenExpr e +freshenExpr (App f a) = do + !f' <- freshenExpr f + !a' <- freshenExpr a + pure $ App f' a' +freshenExpr (Lam b e) = withSubstBndrM b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Lam b' e' +freshenExpr (Let b e) = do + freshenLocalBind b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Let b' e' +freshenExpr (Case e b ty alts) = do + !e' <- freshenExpr e + withSubstBndrM b $ \(!b') -> do + !ty' <- substTy <$> ask <*> pure ty + let do_alt (Alt con bs e) = withSubstBndrsM bs $ \(!bs') -> + Alt con bs' <$!> freshenExpr e + !alts' <- traverse do_alt alts + pure $ Case e' b' ty' alts' ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -529,7 +529,8 @@ cprAnalBind env id rhs isDataStructure :: Id -> Bool -- See Note [CPR for data structures] isDataStructure id = - not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id) + not (isJoinId id) && idArity id == 0 && isEvaldUnfolding unf && hasCoreUnfolding unf + where unf = idUnfolding id -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,23 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + -- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds) + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +441,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +490,65 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty') + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds + + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () - alt_ty3 + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +561,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +622,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +988,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1048,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1101,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1233,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1907,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1927,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1937,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -1968,16 +1954,16 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take threshold_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] - - get_dmd :: Id -> Demand - get_dmd bndr + arg_triples = + take threshold_arity $ + zipWith (\b dmd -> (idType b, NotMarkedStrict, add_bot_boxity dmd)) + (filter isId bndrs) + rhs_dmds + + add_bot_boxity :: Demand -> Demand + add_bot_boxity dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2034,19 +2020,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2151,64 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + -- annotation done in dmdAnalRhsSig + -- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2321,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2406,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2423,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2448,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2472,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2580,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2679,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.FreshenUniques ( freshenUniques ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) @@ -148,7 +149,8 @@ getCoreToDo dflags hpt_rule_base extra_vars maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase) - | phase `elem` strictnessBefore dflags = CoreDoDemand False + | phase `elem` strictnessBefore dflags + = CoreDoPasses [CoreFreshenUniques, CoreDoDemand False] maybe_strictness_before _ = CoreDoNothing @@ -169,8 +171,8 @@ getCoreToDo dflags hpt_rule_base extra_vars simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter (initGentleSimplMode dflags) hpt_rule_base - dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] + dmd_cpr_ww = if ww_on then [CoreFreshenUniques,CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreFreshenUniques,CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] demand_analyser = (CoreDoPasses ( @@ -338,7 +340,8 @@ getCoreToDo dflags hpt_rule_base extra_vars -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) (CoreDoDemand False), + runWhen (strictness || late_dmd_anal) $ CoreDoPasses + [ CoreFreshenUniques, CoreDoDemand False ], maybe_rule_check FinalPhase, @@ -517,6 +520,9 @@ doCorePass pass guts = do CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} addLateCostCentresMG guts + CoreFreshenUniques -> {-# SCC "FreshenUniques" #-} + updateBinds freshenUniques + CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -65,6 +65,7 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep | CoreAddCallerCcs | CoreAddLateCcs + | CoreFreshenUniques instance Outputable CoreToDo where ppr (CoreDoSimplify _) = text "Simplifier" @@ -92,6 +93,7 @@ instance Outputable CoreToDo where ppr (CoreDoRuleCheck {}) = text "Rule check" ppr CoreDoNothing = text "CoreDoNothing" ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + ppr CoreFreshenUniques = text "CoreFreshenUniques" pprPassDetails :: CoreToDo -> SDoc pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -83,6 +83,7 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreFreshenUniques = Just Opt_D_dump_freshen coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -118,6 +118,7 @@ data DumpFlag | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) | Opt_D_dump_call_arity | Opt_D_dump_exitify + | Opt_D_dump_freshen -- ^ FreshenUniques | Opt_D_dump_dmdanal | Opt_D_dump_dmd_signatures | Opt_D_dump_cpranal ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1461,6 +1461,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-freshen" + (setDumpFlag Opt_D_dump_freshen) , make_dep_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_dmdanal) "Use `-ddump-dmdanal` instead" ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -333,6 +333,7 @@ Library GHC.Core.ConLike GHC.Core.DataCon GHC.Core.FamInstEnv + GHC.Core.FreshenUniques GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint @@ -431,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== docs/users_guide/debugging.rst ===================================== @@ -481,6 +481,13 @@ subexpression elimination pass. Dump static argument transformation pass output (see :ghc-flag:`-fstatic-argument-transformation`) +.. ghc-flag:: -ddump-freshen + :shortdesc: Dump output after freshening uniques + :type: dynamic + + Dump the Core after each run of FreshenUniques, which makes sure that each + binder's Unique is indeed globally unique. + .. ghc-flag:: -ddump-worker-wrapper :shortdesc: Dump worker-wrapper output :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b67dc3df2132554ec11b721946f85c25386b816e...8d699a6a19296aec591dd22f2030965ebe480e4d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b67dc3df2132554ec11b721946f85c25386b816e...8d699a6a19296aec591dd22f2030965ebe480e4d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 00:18:33 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 05 Jan 2024 19:18:33 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] More improvements Message-ID: <65989c596facb_174e57277d5746923a@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: ee179934 by Simon Peyton Jones at 2024-01-06T00:18:14+00:00 More improvements - - - - - 10 changed files: - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/Language/Haskell/Syntax/Expr.hs Changes: ===================================== compiler/GHC/Core/TyCo/Rep.hs ===================================== @@ -49,7 +49,7 @@ module GHC.Core.TyCo.Rep ( mkFunTy, mkNakedFunTy, mkVisFunTy, mkScaledFunTys, mkInvisFunTy, mkInvisFunTys, - tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys, + tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, mkVisFunTyMany, mkVisFunTysMany, @@ -782,9 +782,10 @@ tcMkScaledFunTys :: [Scaled Type] -> Type -> Type -- All visible args -- Result type must be TypeLike -- No mkFunTy assert checking; result kind may not be zonked -tcMkScaledFunTys tys ty = foldr mk ty tys - where - mk (Scaled mult arg) res = tcMkVisFunTy mult arg res +tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys + +tcMkScaledFunTy :: Scaled Type -> Type -> Type +tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res --------------- -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder ===================================== compiler/GHC/Tc/Gen/Arrow.hs ===================================== @@ -263,8 +263,8 @@ tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty LamSingle -> id -- Avoids clutter in the vanilla-lambda form _ -> addErrCtxt (cmdCtxt cmd)) $ do { let match_ctxt = ArrowLamAlt lam_variant - ; checkArgCounts (ArrowMatchCtxt match_ctxt) match - ; (wrap, match') <- tcCmdMatchLambda env match_ctxt match cmd_ty + ; arity <- checkArgCounts (ArrowMatchCtxt match_ctxt) match + ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) } ------------------------------------------- @@ -319,7 +319,7 @@ tcCmdMatches :: CmdEnv -> CmdType -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty) - = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) + = tcCaseMatches match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt, mc_body = mc_body } @@ -328,15 +328,14 @@ tcCmdMatches env scrut_ty matches (stk, res_ty) -- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'. tcCmdMatchLambda :: CmdEnv - -> HsArrowMatchContext + -> HsArrowMatchContext -> Arity -> MatchGroup GhcRn (LHsCmd GhcRn) -> CmdType -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) -tcCmdMatchLambda env - ctxt +tcCmdMatchLambda env ctxt arity mg at MG { mg_alts = L l matches, mg_ext = origin } (cmd_stk, res_ty) - = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs arity cmd_stk ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys ; matches' <- forM matches $ @@ -348,9 +347,6 @@ tcCmdMatchLambda env ; return (mkWpCastN co, mg') } where - n_pats | isEmptyMatchGroup mg = 1 -- must be lambda-case - | otherwise = matchGroupArity mg - -- Check the patterns, and the GRHSs inside tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss })) = do { (pats', grhss') <- setSrcSpanA mtch_loc $ ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -23,7 +23,7 @@ where import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) @@ -627,12 +627,18 @@ tcPolyCheck prag_fn , fun_matches = matches })) = do { traceTc "tcPolyCheck" (ppr sig) + -- Make a new Name, whose SrcSpan is nm_loc. For a ClassOp + -- The original Name, in the FunBind{fun_id}, is bound in the + -- class declaration, whereas we want a Name bound right here. + -- We pass mono_name to tcFunBindMatches which in turn puts it in + -- the BinderStack, whence it shows up in "Relevant bindings.." ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) + ; mult <- tcMultAnn (HsNoMultAnn noExtField) ; (wrap_gen, (wrap_res, matches')) <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> setSrcSpanA bind_loc $ - tcMatchesFun ctxt mult matches invis_pat_tys rho_ty + tcFunBindMatches ctxt mono_name mult matches invis_pat_tys rho_ty -- We make a funny AbsBinds, abstracting over nothing, -- just so we have somewhere to put the SpecPrags. @@ -1358,7 +1364,7 @@ tcMonoBinds is_rec sig_fn no_gen <- tcInferFRR (FRRBinder name) $ \ exp_ty -> -- tcInferFRR: the type of a let-binder must have -- a fixed runtime rep. See #23176 - tcMatchesFun (InfSigCtxt name) mult matches [] exp_ty + tcFunBindMatches (InfSigCtxt name) name mult matches [] exp_ty ; mono_id <- newLetBndr no_gen name mult rhs_ty' ; return (unitBag $ L b_loc $ @@ -1634,9 +1640,10 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { let mono_ty = idType mono_id + mono_name = idName mono_id ; traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr mono_ty) - ; (co_fn, matches') <- tcMatchesFun (InfSigCtxt (idName mono_id)) mult - matches [] (mkCheckExpType mono_ty) + ; (co_fn, matches') <- tcFunBindMatches (InfSigCtxt mono_name) mono_name mult + matches [] (mkCheckExpType mono_ty) ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' , fun_ext = (co_fn, []) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -57,7 +57,8 @@ import GHC.Rename.Expr ( mkExpandedExpr ) import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow -import GHC.Tc.Gen.Match +import GHC.Tc.Gen.Match( TcMatchCtxt(..), tcBody, tcLambdaMatches, tcCaseMatches + , tcGRHS, tcDoStmts ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType import GHC.Tc.Zonk.TcType @@ -180,7 +181,7 @@ tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) -- We begin with a special case for HsLam, in case the pushed-down type -- is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int tcPolyExpr e@(HsLam x lam_variant matches) res_ty - = do { (wrap, matches') <- tcMatchLambda e lam_variant matches [] res_ty + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } -- This HsPar case means that the lambda can be wrapped in parens @@ -280,7 +281,7 @@ tcExpr e@(HsIPVar _ x) res_ty origin = IPOccOrigin x tcExpr e@(HsLam x lam_variant matches) res_ty - = do { (wrap, matches') <- tcMatchLambda e lam_variant matches [] res_ty + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } {- @@ -380,7 +381,7 @@ tcExpr (HsCase x scrut matches) res_ty mult <- newFlexiTyVarTy multiplicityTy -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma - -- would also be possible (tcMatchesCase accepts sigma-types) + -- would also be possible (tcCaseMatches accepts sigma-types) -- Interesting litmus test: do these two behave the same? -- case id of {..} -- case (\v -> v) of {..} @@ -389,7 +390,7 @@ tcExpr (HsCase x scrut matches) res_ty ; traceTc "HsCase" (ppr scrut_ty) ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty - ; (mult_co_wrap, matches') <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty + ; (mult_co_wrap, matches') <- tcCaseMatches match_ctxt (Scaled mult scrut_ty) matches res_ty ; return (HsCase x (mkLHsWrap mult_co_wrap scrut') matches') } where match_ctxt = MC { mc_what = x, @@ -427,11 +428,14 @@ Not using 'sup' caused #23814. -} tcExpr (HsMultiIf _ alts) res_ty - = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts + = do { (ues, alts') <- mapAndUnzipM tc_alt alts ; res_ty <- readExpType res_ty ; tcEmitBindingUsage (supUEs ues) -- See Note [MultiWayIf linearity checking] ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + where + match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } + tc_alt alt = tcCollectingUsage $ + wrapLocMA (tcGRHS match_ctxt res_ty) alt tcExpr (HsDo _ do_or_lc stmts) res_ty = tcDoStmts do_or_lc stmts res_ty ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -30,7 +30,7 @@ module GHC.Tc.Gen.Head , addHeadCtxt, addExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprNC ) -import {-# SOURCE #-} GHC.Tc.Gen.Match( tcMatchLambda ) +import {-# SOURCE #-} GHC.Tc.Gen.Match( tcLambdaMatches ) import GHC.Prelude import GHC.Hs @@ -994,7 +994,7 @@ tcExprSig expr (TcCompleteSig sig) -- (\@a -> blah) :: forall b. woo go (L loc e@(HsLam x lam_variant matches)) = setSrcSpanA loc $ - do { (wrap, matches') <- tcMatchLambda e lam_variant matches pat_tys rho_ty + do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys rho_ty ; return (L loc $ mkHsWrap wrap $ HsLam x lam_variant matches') } go (L _ (HsPar _ expr)) = go expr go expr -- Even though we have skolemised, call tcCheckPolyExpr so that ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -15,11 +15,11 @@ -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match - ( tcMatchesFun + ( tcFunBindMatches + , tcCaseMatches + , tcLambdaMatches , tcGRHS , tcGRHSsPat - , tcMatchesCase - , tcMatchLambda , TcMatchCtxt(..) , TcStmtChecker , TcExprStmtChecker @@ -74,6 +74,7 @@ import GHC.Driver.DynFlags ( getDynFlags ) import GHC.Types.Name import GHC.Types.Id import GHC.Types.SrcLoc +import GHC.Types.Basic( Arity ) import Control.Monad import Control.Arrow ( second ) @@ -84,32 +85,28 @@ import GHC.Types.Basic (TopLevelFlag(..)) {- ************************************************************************ * * -\subsection{tcMatchesFun, tcMatchesCase} +\subsection{tcFunBindMatches, tcCaseMatches} * * ************************************************************************ - at tcMatchesFun@ typechecks a @[Match]@ list which occurs in a - at FunMonoBind@. The second argument is the name of the function, which +`tcFunBindMatches` typechecks a `[Match]` list which occurs in a +`FunBind`. The second argument is the name of the function, which is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. +same number of arguments before using `tcMatches` to do the work. -} -tcMatchesFun :: UserTypeCtxt - -> Mult -- The multiplicity of the binder - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] -- Scoped skolemised binders - -> ExpSigmaType -- Expected type of function - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -tcMatchesFun ctxt mult matches invis_pat_tys exp_ty +tcFunBindMatches :: UserTypeCtxt -> Name + -> Mult -- The multiplicity of the binder + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Scoped skolemised binders + -> ExpSigmaType -- Expected type of function + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty = assertPpr (funBindPrecondition matches) (pprMatches matches) $ do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) - ; checkArgCounts hs_match_ctxt matches + arity <- checkArgCounts hs_match_ctxt matches + + ; traceTc "tcFunBindMatches" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; (wrap_fun, (wrap_mult, r)) <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> @@ -118,8 +115,8 @@ tcMatchesFun ctxt mult matches invis_pat_tys exp_ty -- consuming its rhs Many times. tcExtendBinderStack [mk_binder_stack_item fun_name mult exp_ty pat_tys rhs_ty] $ - do { traceTc "tcMatchesFun" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys - , ppr pat_tys $$ ppr exp_ty ]) + do { traceTc "tcFunBindMatches" (vcat [ pprUserTypeCtxt ctxt, ppr invis_pat_tys + , ppr pat_tys $$ ppr exp_ty ]) ; tcMatches tc_match_ctxt (invis_pat_tys ++ pat_tys) rhs_ty matches } ; return (wrap_fun <.> wrap_mult, r) } @@ -128,10 +125,8 @@ tcMatchesFun ctxt mult matches invis_pat_tys exp_ty match1 :: Match GhcRn (LHsExpr GhcRn) hs_match_ctxt :: HsMatchContext GhcRn (L _ match1 : _) = unLoc (mg_alts matches) - Match { m_pats = pats1, m_ctxt = hs_match_ctxt } = match1 - FunRhs { mc_fun = L _ fun_name } = hs_match_ctxt + Match { m_ctxt = hs_match_ctxt } = match1 - arity = length pats1 tc_match_ctxt = MC { mc_what = hs_match_ctxt, mc_body = tcBody } herald = ExpectedFunTyMatches (NameThing fun_name) matches @@ -155,17 +150,17 @@ funBindPrecondition (MG { mg_alts = L _ alts }) is_fun_rhs (L _ (Match { m_ctxt = FunRhs {} })) = True is_fun_rhs _ = False -tcMatchLambda :: HsExpr GhcRn -> HsLamVariant - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] -- Already skolemised - -> ExpSigmaType -- NB can be a sigma-type - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -tcMatchLambda e lam_variant matches invis_pat_tys res_ty - = do { checkArgCounts (mc_what match_ctxt) matches +tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Already skolemised + -> ExpSigmaType -- NB can be a sigma-type + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcLambdaMatches e lam_variant matches invis_pat_tys res_ty + = do { arity <- checkArgCounts (mc_what match_ctxt) matches -- Check argument counts since this is also used for \cases ; (wrapper, (mult_co_wrap, r)) - <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> + <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt (invis_pat_tys ++ pat_tys) rhs_ty matches ; return (wrapper <.> mult_co_wrap, r) } @@ -174,15 +169,12 @@ tcMatchLambda e lam_variant matches invis_pat_tys res_ty herald = ExpectedFunTyLam lam_variant e -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify - n_pats | isEmptyMatchGroup matches = 1 -- must be lambda-case - | otherwise = matchGroupArity matches - {- - at tcMatchesCase@ doesn't do the argument-count check because the + at tcCaseMatches@ doesn't do the argument-count check because the parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) => +tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) => TcMatchCtxt body -- ^ Case context -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives @@ -191,7 +183,7 @@ tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) => -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty -tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty +tcCaseMatches ctxt (Scaled scrut_mult scrut_ty) matches res_ty = tcMatches ctxt [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind at . @@ -1212,25 +1204,33 @@ the variables they bind into scope, and typecheck the thing_inside. -} -- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same --- number of args are used in each equation. +-- number of /required/ args are used in each equation. +-- Returns the arity, the number of required args +-- E.g. f @a True y = ... +-- f False z = ... +-- The MatchGroup for `f` has arity 2, not 3 checkArgCounts :: AnnoBody body - => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () + => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM Arity checkArgCounts _ (MG { mg_alts = L _ [] }) - = return () + = return 1 -- See Note [Empty MatchGroups] in GHC.Rename.Bind + -- case e of {} or \case {} + -- Both have arity 1 + checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) | null matches -- There was only one match; nothing to check - = return () + = return n_args1 -- Two or more matches: check that they agree on arity | Just bad_matches <- mb_bad_matches = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext $ MatchArgMatches match1 bad_matches | otherwise - = return () + = return n_args1 where - n_args1 = args_in_match match1 - mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1] + n_args1 = reqd_args_in_match match1 + mb_bad_matches = NE.nonEmpty [m | m <- matches, reqd_args_in_match m /= n_args1] - args_in_match :: (LocatedA (Match GhcRn body1) -> Int) - args_in_match (L _ (Match { m_pats = pats })) = length pats + reqd_args_in_match :: LocatedA (Match GhcRn body1) -> Arity + -- Counts the number of /required/ args in the match + reqd_args_in_match (L _ (Match { m_pats = pats })) = length pats ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -4,6 +4,7 @@ import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( UserTypeCtxt ) import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) import GHC.Hs.Extension ( GhcRn, GhcTc ) tcGRHSsPat :: Mult @@ -11,15 +12,15 @@ tcGRHSsPat :: Mult -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: UserTypeCtxt - -> Mult - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcFunBindMatches :: UserTypeCtxt -> Name + -> Mult + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -tcMatchLambda :: HsExpr GhcRn -> HsLamVariant - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -203,7 +203,7 @@ data TcIdSigInst Note that "sig_inst_tau" might actually be a polymorphic type, if the original function had a signature like forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that +But that's ok: tcFunBindMatches (called by tcRhs) can deal with that It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class. Note [Quantified variables in partial type signatures] ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -177,12 +177,11 @@ matchActualFunTySigma herald mb_thing err_info fun_ty ------------ defer fun_ty - = do { arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald 1) + = do { arg_ty <- new_check_arg_ty herald 1 ; res_ty <- newOpenFlexiTyVarTy - ; mult <- newFlexiTyVarTy multiplicityTy - ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty + ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } + ; return (mkWpCastN co, arg_ty, res_ty) } ------------ mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) @@ -347,7 +346,7 @@ Example: The body of `f` is a lambda abstraction, so we must be able to split off one argument type from its type. This is handled by `matchExpectedFunTys` - (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that + (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that looks like this: f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) @@ -388,10 +387,23 @@ matchExpectedFunTys :: forall a. -- Postcondition: -- If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{} -- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{} -matchExpectedFunTys herald ctx arity exp_ty thing_inside - = case exp_ty of - Check ty -> check 0 [] ty - _ -> defer 0 [] exp_ty +matchExpectedFunTys herald _ arity (Infer inf_res) thing_inside + = do { arg_tys <- mapM new_infer_arg_ty [1 .. arity] + ; res_ty <- newInferExpType + ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty + ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys + ; res_ty <- readExpType res_ty + ; co <- fillInferResult (mkScaledFunTys arg_tys res_ty) inf_res + ; return (mkWpCastN co, result) } + where + new_infer_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR) + new_infer_arg_ty arg_pos -- position for error messages only + = do { mult <- newFlexiTyVarTy multiplicityTy + ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult inf_hole) } + +matchExpectedFunTys herald ctx arity (Check ty) thing_inside + = check 0 [] ty where check :: Arity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a) -- `check` is called only in the Check{} case @@ -442,7 +454,8 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside ; let wrap_gen = mkWpVisTyLam tv' body_ty' <.> mkWpLet ev_binds ; return (wrap_gen <.> wrap_res, result) } - check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) + check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult + , ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ do { let arg_pos = n_so_far + 1 ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty @@ -458,7 +471,7 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside = do { cts <- readMetaTyVar tv ; case cts of Indirect ty' -> check n_so_far rev_pat_tys ty' - Flexi -> defer n_so_far rev_pat_tys (mkCheckExpType ty) } + Flexi -> defer n_so_far rev_pat_tys ty } -- In all other cases we bale out into ordinary unification -- However unlike the meta-tyvar case, we are sure that the @@ -477,28 +490,28 @@ matchExpectedFunTys herald ctx arity exp_ty thing_inside -- anyway, because it may be useful. See also #9605. check n_so_far rev_pat_tys res_ty = addErrCtxtM (mkFunTysMsg herald arity fun_ty) $ - defer n_so_far rev_pat_tys res_exp_ty + defer n_so_far rev_pat_tys res_ty where res_exp_ty = mkCheckExpType res_ty fun_ty = reconstructCheckType (reverse rev_pat_tys) res_exp_ty ------------ - defer :: Arity -> [ExpPatType] -> ExpRhoType -> TcM (HsWrapper, a) + defer :: Arity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a) defer n_so_far rev_pat_tys fun_ty - = do { more_arg_tys <- mapM new_exp_arg_ty [n_so_far + 1 .. arity] - ; res_ty <- newInferExpType - ; result <- thing_inside (reverse rev_pat_tys ++ map ExpFunPatTy more_arg_tys) res_ty - ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty - ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (wrap, result) } - - new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR) - new_exp_arg_ty arg_pos -- position for error messages only - = mkScaled <$> newFlexiTyVarTy multiplicityTy - <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + = do { more_arg_tys <- mapM (new_check_arg_ty herald) [n_so_far + 1 .. arity] + ; let all_pats = reverse rev_pat_tys ++ + map (ExpFunPatTy . fmap mkCheckExpType) more_arg_tys + ; res_ty <- newOpenFlexiTyVarTy + ; result <- thing_inside all_pats (mkCheckExpType res_ty) + + ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty + ; return (mkWpCastN co, result) } + +new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty herald arg_pos -- Position for error messages only + = do { mult <- newFlexiTyVarTy multiplicityTy + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult arg_ty) } mkFunTysMsg :: ExpectedFunTyOrigin -> Arity ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -308,9 +308,9 @@ data HsExpr p | HsLam (XLam p) HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases (MatchGroup p (LHsExpr p)) - -- ^ LamSingle: one match + -- ^ LamSingle: one match of arity >= 1 -- LamCase: many arity-1 matches - -- LamCases: many matches of uniform arity + -- LamCases: many matches of uniform arity >= 1 -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', -- 'GHC.Parser.Annotation.AnnRarrow', View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee179934b4ad3eb3ad68bccc7a0c6c148b445562 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ee179934b4ad3eb3ad68bccc7a0c6c148b445562 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 15:37:31 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 06 Jan 2024 10:37:31 -0500 Subject: [Git][ghc/ghc][wip/dmdanal-annotation-state] 3 commits: Freshen uniques before demand analysis Message-ID: <659973bb90a63_1e989e6b5f78874561@gitlab.mail> Sebastian Graf pushed to branch wip/dmdanal-annotation-state at Glasgow Haskell Compiler / GHC Commits: 92fe370a by Sebastian Graf at 2024-01-06T16:35:47+01:00 Freshen uniques before demand analysis - - - - - 6c9e9f42 by Sebastian Graf at 2024-01-06T16:35:48+01:00 DmdAnal: Explicit annotation state - - - - - d19618e4 by Sebastian Graf at 2024-01-06T16:37:06+01:00 Revert change to substUnfolding Apparently, forcing the uf_is_value property allocates about 0.5% - - - - - 14 changed files: - + compiler/GHC/Core/FreshenUniques.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst Changes: ===================================== compiler/GHC/Core/FreshenUniques.hs ===================================== @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} + +module GHC.Core.FreshenUniques ( freshenUniques ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.TyCo.Subst + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +import qualified Data.List as List +import Data.Traversable (for) + +type M a = ReaderT Subst (State InScopeSet) a + +-- | Gives fresh uniques to all 'Var's ocurring in terms of the 'CoreProgram'. +-- It works by bringing all 'Var's into scope at once through calls to +-- 'substBndr'. +freshenUniques :: CoreProgram -> CoreProgram +freshenUniques prog = evalState (runReaderT (freshenTopBinds prog) emptySubst) emptyInScopeSet + +freshenTopBinds :: [CoreBind] -> M [CoreBind] +freshenTopBinds binds = do + -- The scoping semantics of top-level bindings are quite surprising; + -- All bindings are brought into scope at the beginning. Hence they + -- mustn't shadow each other. + -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/19529 + let bs = bindersOfBinds binds + -- ... hence we bring them all into scope here, without substituting anything. + let in_scope = mkInScopeSet $ mkVarSet bs + lift $ put $! in_scope + -- And we can be sure that no shadowing has happened so far, hence the assert: + massertPpr (sizeVarSet (getInScopeVars in_scope) == length bs) + (hang (text "Non-unique top-level Id(s)!") 2 $ + ppr (filter (\grp -> length grp > 1) (List.group bs))) + local (`setInScope` in_scope) $ + traverse freshenTopBind binds + +freshenTopBind :: CoreBind -> M CoreBind +-- Binders are already fresh; see freshenTopBinds above +freshenTopBind (NonRec b rhs) = NonRec b <$!> freshenExpr rhs +freshenTopBind (Rec binds) = fmap Rec $ for binds $ \(b, rhs) -> do + !rhs' <- freshenExpr rhs + pure (b, rhs') + +-- | `wrapSubstFunM f ids k` wraps a `substBndrs`-like function `f` such that +-- +-- 1. The `InScopeSet` in the state of `M` is taken for the substitution of +-- the binders `ids`. +-- 2. The extended `Subst` is available in the continuation `k` +-- 3. (But after this function exits, the `Subst` is reset, reader-like, with +-- no trace of `ids`) +-- 4. After this function exits, the `InScopeSet` is still extended with `ids`. +wrapSubstFunM :: (Subst -> ids -> (Subst, ids)) -> ids -> (ids -> M r) -> M r +wrapSubstFunM f ids k = ReaderT $ \subst -> do + in_scope <- get + let (!subst', !ids') = f (subst `setInScope` in_scope) ids + put $! getSubstInScope subst' + runReaderT (k ids') subst' + +withSubstBndrM :: Var -> (Var -> M r) -> M r +withSubstBndrM = wrapSubstFunM substBndr + +withSubstBndrsM :: [Var] -> ([Var] -> M r) -> M r +withSubstBndrsM = wrapSubstFunM substBndrs + +withSubstRecBndrsM :: [Id] -> ([Id] -> M r) -> M r +withSubstRecBndrsM = wrapSubstFunM substRecBndrs + +-- | The binders of the `CoreBind` are \"in scope\" in the +-- continuation. +freshenLocalBind :: CoreBind -> (CoreBind -> M r) -> M r +freshenLocalBind (NonRec b rhs) k = do + !rhs' <- freshenExpr rhs + withSubstBndrM b $ \(!b') -> k $! NonRec b' rhs' +freshenLocalBind (Rec binds) k = do + let (bs, rhss) = unzip binds + withSubstRecBndrsM bs $ \(!bs') -> do + !rhss' <- traverse freshenExpr rhss + k $! Rec $! zip bs' rhss' + +freshenExpr :: CoreExpr -> M CoreExpr +-- Quite like substExpr, but we freshen binders unconditionally. +-- So maybe this is more like substExpr, if we had that +freshenExpr (Coercion co) = Coercion <$!> (substCo <$> ask <*> pure co) +freshenExpr (Type t) = Type <$!> (substTy <$> ask <*> pure t) +freshenExpr e at Lit{} = pure e +freshenExpr (Var v) = lookupIdSubst <$> ask <*> pure v +freshenExpr (Tick t e) = do + t <- substTickish <$> ask <*> pure t + Tick t <$!> freshenExpr e +freshenExpr (Cast e co) = do + co' <- substCo <$> ask <*> pure co + flip Cast co' <$!> freshenExpr e +freshenExpr (App f a) = do + !f' <- freshenExpr f + !a' <- freshenExpr a + pure $ App f' a' +freshenExpr (Lam b e) = withSubstBndrM b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Lam b' e' +freshenExpr (Let b e) = do + freshenLocalBind b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Let b' e' +freshenExpr (Case e b ty alts) = do + !e' <- freshenExpr e + withSubstBndrM b $ \(!b') -> do + !ty' <- substTy <$> ask <*> pure ty + let do_alt (Alt con bs e) = withSubstBndrsM bs $ \(!bs') -> + Alt con bs' <$!> freshenExpr e + !alts' <- traverse do_alt alts + pure $ Case e' b' ty' alts' ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -529,7 +529,8 @@ cprAnalBind env id rhs isDataStructure :: Id -> Bool -- See Note [CPR for data structures] isDataStructure id = - not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id) + not (isJoinId id) && idArity id == 0 && isEvaldUnfolding unf && hasCoreUnfolding unf + where unf = idUnfolding id -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has @@ -892,6 +893,7 @@ What do we mean by "data structure binding"? Answer: (2) is eval'd (otherwise it's a thunk, Note [CPR for thunks] applies) (3) not (isJoinId id) (otherwise it's a function and its more efficient to analyse it just once rather than at each call site) + (4) has Core unfolding (otherwise, for OtherCon we can't reconstruct Cpr) But (S1) leads to a new Problem P2: We can't just stop giving DataCon application bindings the CPR *property*, for example the factorial function after FloatOut ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,23 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + -- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds) + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +441,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +490,65 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty') + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds + + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () - alt_ty3 + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +561,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +622,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +988,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1048,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1101,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1233,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1907,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1927,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1937,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -1968,16 +1954,16 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take threshold_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] - - get_dmd :: Id -> Demand - get_dmd bndr + arg_triples = + take threshold_arity $ + zipWith (\b dmd -> (idType b, NotMarkedStrict, add_bot_boxity dmd)) + (filter isId bndrs) + rhs_dmds + + add_bot_boxity :: Demand -> Demand + add_bot_boxity dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2034,19 +2020,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2151,64 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + -- annotation done in dmdAnalRhsSig + -- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2321,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2406,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2423,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2448,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2472,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2580,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2679,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.FreshenUniques ( freshenUniques ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) @@ -148,7 +149,8 @@ getCoreToDo dflags hpt_rule_base extra_vars maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase) - | phase `elem` strictnessBefore dflags = CoreDoDemand False + | phase `elem` strictnessBefore dflags + = CoreDoPasses [CoreFreshenUniques, CoreDoDemand False] maybe_strictness_before _ = CoreDoNothing @@ -169,8 +171,8 @@ getCoreToDo dflags hpt_rule_base extra_vars simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter (initGentleSimplMode dflags) hpt_rule_base - dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] + dmd_cpr_ww = if ww_on then [CoreFreshenUniques,CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreFreshenUniques,CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] demand_analyser = (CoreDoPasses ( @@ -338,7 +340,8 @@ getCoreToDo dflags hpt_rule_base extra_vars -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) (CoreDoDemand False), + runWhen (strictness || late_dmd_anal) $ CoreDoPasses + [ CoreFreshenUniques, CoreDoDemand False ], maybe_rule_check FinalPhase, @@ -517,6 +520,9 @@ doCorePass pass guts = do CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} addLateCostCentresMG guts + CoreFreshenUniques -> {-# SCC "FreshenUniques" #-} + updateBinds freshenUniques + CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -65,6 +65,7 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep | CoreAddCallerCcs | CoreAddLateCcs + | CoreFreshenUniques instance Outputable CoreToDo where ppr (CoreDoSimplify _) = text "Simplifier" @@ -92,6 +93,7 @@ instance Outputable CoreToDo where ppr (CoreDoRuleCheck {}) = text "Rule check" ppr CoreDoNothing = text "CoreDoNothing" ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + ppr CoreFreshenUniques = text "CoreFreshenUniques" pprPassDetails :: CoreToDo -> SDoc pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -514,10 +514,10 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) (subst',bndrs') = substBndrs subst bndrs args' = map (substExpr subst') args -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src, uf_cache = cache }) +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work - = if uf_is_value cache then evaldUnfolding else NoUnfolding + = NoUnfolding | otherwise -- But keep a stable one! = seqExpr new_tmpl `seq` unf { uf_tmpl = new_tmpl } ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -83,6 +83,7 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreFreshenUniques = Just Opt_D_dump_freshen coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -118,6 +118,7 @@ data DumpFlag | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) | Opt_D_dump_call_arity | Opt_D_dump_exitify + | Opt_D_dump_freshen -- ^ FreshenUniques | Opt_D_dump_dmdanal | Opt_D_dump_dmd_signatures | Opt_D_dump_cpranal ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1461,6 +1461,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-freshen" + (setDumpFlag Opt_D_dump_freshen) , make_dep_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_dmdanal) "Use `-ddump-dmdanal` instead" ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -333,6 +333,7 @@ Library GHC.Core.ConLike GHC.Core.DataCon GHC.Core.FamInstEnv + GHC.Core.FreshenUniques GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint @@ -431,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== docs/users_guide/debugging.rst ===================================== @@ -481,6 +481,13 @@ subexpression elimination pass. Dump static argument transformation pass output (see :ghc-flag:`-fstatic-argument-transformation`) +.. ghc-flag:: -ddump-freshen + :shortdesc: Dump output after freshening uniques + :type: dynamic + + Dump the Core after each run of FreshenUniques, which makes sure that each + binder's Unique is indeed globally unique. + .. ghc-flag:: -ddump-worker-wrapper :shortdesc: Dump worker-wrapper output :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d699a6a19296aec591dd22f2030965ebe480e4d...d19618e4abb1782ce952922646eb2e7f4f112c1d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8d699a6a19296aec591dd22f2030965ebe480e4d...d19618e4abb1782ce952922646eb2e7f4f112c1d You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 17:35:34 2024 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sat, 06 Jan 2024 12:35:34 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Adjust stackFrameHeaderSize Message-ID: <65998f664af4e_1e989e9dbb8e481043@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 2fd984b7 by Sven Tennie at 2024-01-06T18:34:59+01:00 Adjust stackFrameHeaderSize - - - - - 1 changed file: - compiler/GHC/CmmToAsm/RV64/Instr.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/Instr.hs ===================================== @@ -32,9 +32,14 @@ import Data.Maybe (fromMaybe) import GHC.Stack --- | TODO: Should be `2 * spillSlotSize = 16` -stackFrameHeaderSize :: Platform -> Int -stackFrameHeaderSize _ = 64 +-- | Stack frame header size in bytes. +-- +-- The stack frame header is made of the values that are always saved +-- (regardless of the context.) It consists of the saved return address and a +-- pointer to the previous frame. Thus, its size is two stack frame slots which +-- equals two addresses/words (2 * 8 byte). +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * spillSlotSize -- | All registers are 8 byte wide. spillSlotSize :: Int @@ -48,15 +53,13 @@ stackAlign = 16 -- | The number of spill slots available without allocating more. maxSpillSlots :: NCGConfig -> Int maxSpillSlots config --- = 0 -- set to zero, to see when allocMoreStack has to fire. - = let platform = ncgPlatform config - in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + = ((ncgSpillPreallocSize config - stackFrameHeaderSize) `div` spillSlotSize) - 1 -- | Convert a spill slot number to a *byte* offset, with no sign. -spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot +spillSlotToOffset :: Int -> Int +spillSlotToOffset slot + = stackFrameHeaderSize + spillSlotSize * slot -- | Get the registers that are being used by this instruction. -- regUsage doesn't need to do any trickery for jumps and such. @@ -378,7 +381,7 @@ mkSpillInstr config reg delta slot = addSpToIp = ANN (text "Spill: IP <- SP + IP ") $ ADD ip ip sp mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg ip_reg)) - off = spillSlotToOffset config slot + off = spillSlotToOffset slot mkLoadInstr :: NCGConfig @@ -387,7 +390,7 @@ mkLoadInstr -> Int -- spill slot to use -> [Instr] -mkLoadInstr config reg delta slot = +mkLoadInstr _config reg delta slot = case off - delta of imm | fitsIn12bitImm imm -> [mkLdrSpImm imm] imm -> @@ -404,7 +407,7 @@ mkLoadInstr config reg delta slot = addSpToIp = ANN (text "Reload: IP <- SP + IP ") $ ADD ip ip sp mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg ip_reg)) - off = spillSlotToOffset config slot + off = spillSlotToOffset slot -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fd984b78bf87c2a271e6e17950f86556595180b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fd984b78bf87c2a271e6e17950f86556595180b You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 17:59:06 2024 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Sat, 06 Jan 2024 12:59:06 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24295 Message-ID: <659994eabb896_1e989ea553804840c@gitlab.mail> Matthew Craven pushed new branch wip/T24295 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24295 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 18:57:53 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 06 Jan 2024 13:57:53 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24296 Message-ID: <6599a2b1b5da8_1e989ebf4a24485833@gitlab.mail> Sebastian Graf pushed new branch wip/T24296 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24296 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 19:03:20 2024 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sat, 06 Jan 2024 14:03:20 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Delete unnecessary Ppr cases Message-ID: <6599a3f8eb7bf_1e989ec19cf7487216@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: fef187b4 by Sven Tennie at 2024-01-06T20:02:57+01:00 Delete unnecessary Ppr cases - - - - - 2 changed files: - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -634,8 +634,6 @@ pprInstr platform instr = case instr of STR II64 o1 o2 -> op2 (text "\tsd") o1 o2 STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2 STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2 - STR f o1 o2 -> pprPanic "RV64.pprInstr - STR not implemented for ... " - (text "STR" <+> (text.show) f <+> pprOp platform o1 <+> pprOp platform o2) LDR _f o1 (OpImm (ImmIndex lbl off)) -> lines_ [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl @@ -653,12 +651,6 @@ pprInstr platform instr = case instr of -- op_add o1 (text "%pcrel_lo(" <> pprAsmLabel platform lbl <> text ")") line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl - -- TODO: Are these two special cases really needed? - LDR _f o1@(OpReg W8 reg) o2 | isIntRealReg reg -> - op2 (text "\tlb") o1 o2 - LDR _f o1@(OpReg W16 reg) o2 | isIntRealReg reg -> - op2 (text "\tlh") o1 o2 - LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2 LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2 LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2 ===================================== compiler/GHC/CmmToAsm/RV64/Regs.hs ===================================== @@ -145,10 +145,6 @@ classOfRealReg (RealRegSingle i) | i < 32 = RcInteger | otherwise = RcDouble -isIntRealReg :: Reg -> Bool -isIntRealReg (RegReal r) = classOfRealReg r == RcInteger -isIntRealReg _ = False - regDotColor :: RealReg -> SDoc regDotColor reg = case classOfRealReg reg of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef187b4b52ac84140b50765301383c72104c8c4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef187b4b52ac84140b50765301383c72104c8c4 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 19:34:25 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 06 Jan 2024 14:34:25 -0500 Subject: [Git][ghc/ghc][wip/sgraf-improvements] 2 commits: Move testsuite/tests/stranal to testsuite/tests/dmdanal Message-ID: <6599ab4193c00_1e989ed02d4f89496@gitlab.mail> Sebastian Graf pushed to branch wip/sgraf-improvements at Glasgow Haskell Compiler / GHC Commits: e210fcda by Sebastian Graf at 2024-01-06T20:33:45+01:00 Move testsuite/tests/stranal to testsuite/tests/dmdanal A separate commit so that the rename is obvious to Git(Lab) - - - - - 3c50c30f by Sebastian Graf at 2024-01-06T20:33:45+01:00 CoreSubst: Stricten `substBndr` and `cloneBndr` Doing so reduced allocations of `cloneBndr` by about 25%. ``` T9233(normal) ghc/alloc 672,488,656 663,083,216 -1.4% GOOD T9675(optasm) ghc/alloc 423,029,256 415,812,200 -1.7% geo. mean -0.1% minimum -1.7% maximum +0.1% ``` Metric Decrease: T9233 - - - - - 30 changed files: - compiler/GHC/Core/Subst.hs - testsuite/tests/stranal/Makefile → testsuite/tests/dmdanal/Makefile - testsuite/tests/stranal/T10482a.hs → testsuite/tests/dmdanal/T10482a.hs - testsuite/tests/stranal/should_compile/EtaExpansion.hs → testsuite/tests/dmdanal/should_compile/EtaExpansion.hs - testsuite/tests/stranal/should_compile/Makefile → testsuite/tests/dmdanal/should_compile/Makefile - testsuite/tests/stranal/should_compile/T10069.hs → testsuite/tests/dmdanal/should_compile/T10069.hs - testsuite/tests/stranal/should_compile/T10069.stderr → testsuite/tests/dmdanal/should_compile/T10069.stderr - testsuite/tests/stranal/should_compile/T10482.hs → testsuite/tests/dmdanal/should_compile/T10482.hs - testsuite/tests/stranal/should_compile/T10482.stderr → testsuite/tests/dmdanal/should_compile/T10482.stderr - testsuite/tests/stranal/should_compile/T10482a.hs → testsuite/tests/dmdanal/should_compile/T10482a.hs - testsuite/tests/stranal/should_compile/T10482a.stderr → testsuite/tests/dmdanal/should_compile/T10482a.stderr - testsuite/tests/stranal/should_compile/T10694.hs → testsuite/tests/dmdanal/should_compile/T10694.hs - testsuite/tests/stranal/should_compile/T10694.stderr → testsuite/tests/dmdanal/should_compile/T10694.stderr - testsuite/tests/stranal/should_compile/T11770.hs → testsuite/tests/dmdanal/should_compile/T11770.hs - testsuite/tests/stranal/should_compile/T11770.stderr → testsuite/tests/dmdanal/should_compile/T11770.stderr - testsuite/tests/stranal/should_compile/T13031.hs → testsuite/tests/dmdanal/should_compile/T13031.hs - testsuite/tests/stranal/should_compile/T13031.stdout → testsuite/tests/dmdanal/should_compile/T13031.stdout - testsuite/tests/stranal/should_compile/T13077.hs → testsuite/tests/dmdanal/should_compile/T13077.hs - testsuite/tests/stranal/should_compile/T13077a.hs → testsuite/tests/dmdanal/should_compile/T13077a.hs - testsuite/tests/stranal/should_compile/T13143.hs → testsuite/tests/dmdanal/should_compile/T13143.hs - testsuite/tests/stranal/should_compile/T13143.stderr → testsuite/tests/dmdanal/should_compile/T13143.stderr - testsuite/tests/stranal/should_compile/T13380b.hs → testsuite/tests/dmdanal/should_compile/T13380b.hs - testsuite/tests/stranal/should_compile/T15627.hs → testsuite/tests/dmdanal/should_compile/T15627.hs - testsuite/tests/stranal/should_compile/T15627.stderr → testsuite/tests/dmdanal/should_compile/T15627.stderr - testsuite/tests/stranal/should_compile/T16029.hs → testsuite/tests/dmdanal/should_compile/T16029.hs - testsuite/tests/stranal/should_compile/T16029.stdout → testsuite/tests/dmdanal/should_compile/T16029.stdout - testsuite/tests/stranal/should_compile/T17819.hs → testsuite/tests/dmdanal/should_compile/T17819.hs - testsuite/tests/stranal/should_compile/T17819.stderr → testsuite/tests/dmdanal/should_compile/T17819.stderr - testsuite/tests/stranal/should_compile/T17852.hs → testsuite/tests/dmdanal/should_compile/T17852.hs - testsuite/tests/stranal/should_compile/T17852.stdout → testsuite/tests/dmdanal/should_compile/T17852.stdout The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0124714b9d96af9a9923bd28a4f3301a48438a1e...3c50c30fb6732a17936b40f360a3961b5703b8c5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0124714b9d96af9a9923bd28a4f3301a48438a1e...3c50c30fb6732a17936b40f360a3961b5703b8c5 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 20:14:19 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 06 Jan 2024 15:14:19 -0500 Subject: [Git][ghc/ghc][wip/freshen-uniques] 3 commits: CoreSubst: Retain evaluatedness of unstable unfoldings Message-ID: <6599b49bcd4c_1e989ee12f0a897962@gitlab.mail> Sebastian Graf pushed to branch wip/freshen-uniques at Glasgow Haskell Compiler / GHC Commits: 4e2508e1 by Sebastian Graf at 2024-01-05T18:01:18+01:00 CoreSubst: Retain evaluatedness of unstable unfoldings - - - - - 92fe370a by Sebastian Graf at 2024-01-06T16:35:47+01:00 Freshen uniques before demand analysis - - - - - 6c9e9f42 by Sebastian Graf at 2024-01-06T16:35:48+01:00 DmdAnal: Explicit annotation state - - - - - 14 changed files: - + compiler/GHC/Core/FreshenUniques.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Utils.hs - + compiler/GHC/Data/STuple.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst Changes: ===================================== compiler/GHC/Core/FreshenUniques.hs ===================================== @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} + +module GHC.Core.FreshenUniques ( freshenUniques ) where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Subst +import GHC.Core.TyCo.Subst + +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + +import qualified Data.List as List +import Data.Traversable (for) + +type M a = ReaderT Subst (State InScopeSet) a + +-- | Gives fresh uniques to all 'Var's ocurring in terms of the 'CoreProgram'. +-- It works by bringing all 'Var's into scope at once through calls to +-- 'substBndr'. +freshenUniques :: CoreProgram -> CoreProgram +freshenUniques prog = evalState (runReaderT (freshenTopBinds prog) emptySubst) emptyInScopeSet + +freshenTopBinds :: [CoreBind] -> M [CoreBind] +freshenTopBinds binds = do + -- The scoping semantics of top-level bindings are quite surprising; + -- All bindings are brought into scope at the beginning. Hence they + -- mustn't shadow each other. + -- See also https://gitlab.haskell.org/ghc/ghc/-/issues/19529 + let bs = bindersOfBinds binds + -- ... hence we bring them all into scope here, without substituting anything. + let in_scope = mkInScopeSet $ mkVarSet bs + lift $ put $! in_scope + -- And we can be sure that no shadowing has happened so far, hence the assert: + massertPpr (sizeVarSet (getInScopeVars in_scope) == length bs) + (hang (text "Non-unique top-level Id(s)!") 2 $ + ppr (filter (\grp -> length grp > 1) (List.group bs))) + local (`setInScope` in_scope) $ + traverse freshenTopBind binds + +freshenTopBind :: CoreBind -> M CoreBind +-- Binders are already fresh; see freshenTopBinds above +freshenTopBind (NonRec b rhs) = NonRec b <$!> freshenExpr rhs +freshenTopBind (Rec binds) = fmap Rec $ for binds $ \(b, rhs) -> do + !rhs' <- freshenExpr rhs + pure (b, rhs') + +-- | `wrapSubstFunM f ids k` wraps a `substBndrs`-like function `f` such that +-- +-- 1. The `InScopeSet` in the state of `M` is taken for the substitution of +-- the binders `ids`. +-- 2. The extended `Subst` is available in the continuation `k` +-- 3. (But after this function exits, the `Subst` is reset, reader-like, with +-- no trace of `ids`) +-- 4. After this function exits, the `InScopeSet` is still extended with `ids`. +wrapSubstFunM :: (Subst -> ids -> (Subst, ids)) -> ids -> (ids -> M r) -> M r +wrapSubstFunM f ids k = ReaderT $ \subst -> do + in_scope <- get + let (!subst', !ids') = f (subst `setInScope` in_scope) ids + put $! getSubstInScope subst' + runReaderT (k ids') subst' + +withSubstBndrM :: Var -> (Var -> M r) -> M r +withSubstBndrM = wrapSubstFunM substBndr + +withSubstBndrsM :: [Var] -> ([Var] -> M r) -> M r +withSubstBndrsM = wrapSubstFunM substBndrs + +withSubstRecBndrsM :: [Id] -> ([Id] -> M r) -> M r +withSubstRecBndrsM = wrapSubstFunM substRecBndrs + +-- | The binders of the `CoreBind` are \"in scope\" in the +-- continuation. +freshenLocalBind :: CoreBind -> (CoreBind -> M r) -> M r +freshenLocalBind (NonRec b rhs) k = do + !rhs' <- freshenExpr rhs + withSubstBndrM b $ \(!b') -> k $! NonRec b' rhs' +freshenLocalBind (Rec binds) k = do + let (bs, rhss) = unzip binds + withSubstRecBndrsM bs $ \(!bs') -> do + !rhss' <- traverse freshenExpr rhss + k $! Rec $! zip bs' rhss' + +freshenExpr :: CoreExpr -> M CoreExpr +-- Quite like substExpr, but we freshen binders unconditionally. +-- So maybe this is more like substExpr, if we had that +freshenExpr (Coercion co) = Coercion <$!> (substCo <$> ask <*> pure co) +freshenExpr (Type t) = Type <$!> (substTy <$> ask <*> pure t) +freshenExpr e at Lit{} = pure e +freshenExpr (Var v) = lookupIdSubst <$> ask <*> pure v +freshenExpr (Tick t e) = do + t <- substTickish <$> ask <*> pure t + Tick t <$!> freshenExpr e +freshenExpr (Cast e co) = do + co' <- substCo <$> ask <*> pure co + flip Cast co' <$!> freshenExpr e +freshenExpr (App f a) = do + !f' <- freshenExpr f + !a' <- freshenExpr a + pure $ App f' a' +freshenExpr (Lam b e) = withSubstBndrM b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Lam b' e' +freshenExpr (Let b e) = do + freshenLocalBind b $ \(!b') -> do + !e' <- freshenExpr e + pure $ Let b' e' +freshenExpr (Case e b ty alts) = do + !e' <- freshenExpr e + withSubstBndrM b $ \(!b') -> do + !ty' <- substTy <$> ask <*> pure ty + let do_alt (Alt con bs e) = withSubstBndrsM bs $ \(!bs') -> + Alt con bs' <$!> freshenExpr e + !alts' <- traverse do_alt alts + pure $ Case e' b' ty' alts' ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -529,7 +529,8 @@ cprAnalBind env id rhs isDataStructure :: Id -> Bool -- See Note [CPR for data structures] isDataStructure id = - not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id) + not (isJoinId id) && idArity id == 0 && isEvaldUnfolding unf && hasCoreUnfolding unf + where unf = idUnfolding id -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has @@ -892,6 +893,7 @@ What do we mean by "data structure binding"? Answer: (2) is eval'd (otherwise it's a thunk, Note [CPR for thunks] applies) (3) not (isJoinId id) (otherwise it's a function and its more efficient to analyse it just once rather than at each call site) + (4) has Core unfolding (otherwise, for OtherCon we can't reconstruct Cpr) But (S1) leads to a new Problem P2: We can't just stop giving DataCon application bindings the CPR *property*, for example the factorial function after FloatOut ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -6,6 +6,7 @@ A demand analysis ----------------- -} +{-# LANGUAGE RankNTypes #-} module GHC.Core.Opt.DmdAnal @@ -45,11 +46,20 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.STuple + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import Data.List ( mapAccumL ) +import Data.Functor.Identity +import Data.STRef +import Control.Monad.ST +import Control.Monad.Trans.Reader +import Control.Monad (zipWithM_) +import GHC.Data.Maybe +import Data.Foldable (foldlM) {- ************************************************************************ @@ -77,12 +87,28 @@ data DmdAnalOpts = DmdAnalOpts -- This is a strict alternative to (,) -- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a +type WithDmdType a = SPair DmdType a + +type AnalM s = ReaderT (DmdAnnotations (STRef s)) (ST s) + +annotate :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> Id -> a -> AnalM s () +annotate ref id !a = ReaderT $ \ann -> modifySTRef' (ref ann) (\env -> extendVarEnv env id a) + +readAnn :: (DmdAnnotations (STRef s) -> STRef s (IdEnv a)) -> AnalM s (IdEnv a) +readAnn ref = ReaderT $ \ann -> readSTRef (ref ann) -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a +runAnalM :: (forall s. AnalM s a) -> DmdAnnotations Identity +runAnalM m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + _a <- runReaderT m env + demands <- readSTRef (da_demands env) + sigs <- readSTRef (da_sigs env) + pure $! DA (Identity demands) (Identity sigs) -data DmdResult a b = R !a !b +discardAnnotations :: (forall s. AnalM s a) -> a +discardAnnotations m = runST $ do + env <- DA <$> newSTRef emptyVarEnv <*> newSTRef emptyVarEnv + runReaderT m env -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. @@ -91,19 +117,16 @@ data DmdResult a b = R !a !b -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + = annotateProgram (runAnalM $ go (emptyAnalEnv opts fam_envs) binds) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + go _ [] = pure nopDmdType + go env (b:bs) = dmdAnalBind TopLevel env topSubDmd b anal_body where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + anal_body env' = do + body_ty <- go env' bs + pure $! body_ty `plusDmdType` keep_alive_roots env' (bindersOf b) keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -119,7 +142,7 @@ dmdAnalProgram opts fam_envs rules binds demandRoot :: AnalEnv -> Id -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) +demandRoot env id = discardAnnotations $ dmdAnalStar env topDmd (Var id) demandRoots :: AnalEnv -> [Id] -> DmdEnv -- See Note [Absence analysis for stable unfoldings and RULES] @@ -187,7 +210,7 @@ Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only if worker/wrapper follows after DmdAnal. If it is not set, and the signature is not subject to Note [Boxity for bottoming functions], DmdAnal tries to transfer over the previous boxity to the new demand signature, in -`setIdDmdAndBoxSig`. +`annotateSig`. Why isn't CprAnal configured with a similar flag? Because if we aren't going to do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) @@ -293,9 +316,9 @@ dmdAnalBind -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -> (AnalEnv -> AnalM s DmdType) -- ^ How to analyse the "body", e.g. -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) + -> AnalM s DmdType dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id @@ -306,17 +329,17 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd +annotateBindIdDemand :: TopLevelFlag -> Id -> Demand -> AnalM s () +annotateBindIdDemand top_lvl id dmd = case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> annotate da_demands id topDmd + _ -> annotate da_demands id dmd -- | Update the demand signature, but be careful not to change boxity info if -- `dmd_do_boxity` is True or if the signature is bottom. -- See Note [Don't change boxity without worker/wrapper] -- and Note [Boxity for bottoming functions]. -setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id -setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ +annotateSig :: DmdAnalOpts -> Id -> DmdSig -> AnalM s () +annotateSig opts id sig = annotate da_sigs id $ if dmd_do_boxity opts || isBottomingSig sig then sig else transferArgBoxityDmdSig (idDmdSig id) sig @@ -338,22 +361,24 @@ dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] + -> (AnalEnv -> AnalM s DmdType) + -> AnalM s DmdType +dmdAnalBindLetUp top_lvl env id rhs anal_body = do + -- See Note [Bringing a new variable into scope] + body_ty <- anal_body (addInScopeAnalEnv env id) - id_dmd' = finaliseLetBoxity env (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + -- See Note [Finalising boxity for demand signatures] + let S2 body_ty' id_dmd = findBndrDmd env body_ty id + let id_dmd' = finaliseLetBoxity env (idType id) id_dmd + annotateBindIdDemand top_lvl id id_dmd' - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + rhs_ty <- dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + let rule_fvs = bndrRuleAndUnfoldingIds id + let final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs + + return final_ty -- | Let bindings can be processed in two ways: -- Down (RHS before body) or Up (body before RHS). @@ -367,25 +392,23 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> AnalM s DmdType) -> AnalM s DmdType dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec + NonRec id rhs -> do + S2 env' weak_fv <- dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + do_rest env' weak_fv [id] + Rec pairs -> do + S2 env' weak_fv <- dmdFix top_lvl env dmd pairs + do_rest env' weak_fv (map fst pairs) where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' + do_rest env' weak_fv bndrs = do + body_ty <- anal_body env' + let dmd_ty = addWeakFVs body_ty weak_fv -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + let S2 final_ty id_dmds = findBndrsDmds env' dmd_ty bndrs + -- pprTraceM "dmdAnalBindLetDown" (ppr bndrs <+> ppr id_dmds) + zipWithM_ (annotateBindIdDemand top_lvl) bndrs id_dmds + pure final_ty -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -418,59 +441,48 @@ anticipateANF e n dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e + -> AnalM s DmdEnv +dmdAnalStar env (n :* sd) e = do -- NB: (:*) expands AbsDmd and BotDmd as needed - | WithDmdType dmd_ty e' <- dmdAnal env sd e - , n' <- anticipateANF e n - -- See Note [Anticipating ANF in demand analysis] - -- and Note [Analysing with absent demand] - = (discardArgDmds $ multDmdType n' dmd_ty, e') + dmd_ty <- dmdAnal env sd e + let n' = anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + pure $! discardArgDmds $ multDmdType n' dmd_ty -- Main Demand Analysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr + -> CoreExpr -> AnalM s DmdType dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) +dmdAnal' env sd (Var var) = pure $! dmdTransform env var sd -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) +dmdAnal' _ _ (Lit _) = pure nopDmdType +dmdAnal' _ _ (Type _) = pure nopDmdType -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) = pure $! noArgsDmdType (coercionDmdEnv co) -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Cast e co) = do + dmd_ty <- dmdAnal env sd e + pure $! dmd_ty `plusDmdType` coercionDmdEnv co -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e +dmdAnal' env sd (Tick _ e) = dmdAnal env sd e -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun +dmdAnal' env dmd (App fun (Type _)) = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env arg_dmd arg - in --- pprTrace "dmdAnal:app" (vcat +dmdAnal' env dmd (App fun arg) = do + -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let call_dmd = mkCalledOnceDmd dmd + fun_ty <- dmdAnal env call_dmd fun + let (arg_dmd, res_ty) = splitDmdTy fun_ty + arg_ty <- dmdAnalStar env arg_dmd arg +-- pprTraceM "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd -- , text "expr =" <+> ppr (App fun arg) -- , text "fun dmd_ty =" <+> ppr fun_ty @@ -478,80 +490,65 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + pure $! res_ty `plusDmdType` arg_ty dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') + | isTyVar var = dmdAnal body_env dmd body + | otherwise = do + let (n, body_dmd) = peelCallDmd dmd + body_ty <- dmdAnal body_env body_dmd body + -- See Note [Bringing a new variable into scope] + let S2 body_ty' dmd = findBndrDmd env body_ty var + -- pprTraceM "dmdAnal:Lam" (ppr var <+> ppr dmd $$ ppr body_ty') + annotate da_demands var dmd + let !lam_ty = addDemand dmd body_ty' + return $! multDmdType n lam_ty + where + body_env = addInScopeAnalEnv env var -- See Note [Bringing a new variable into scope] -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) +dmdAnal' env dmd (Case scrut case_bndr _ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt_con - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + | want_precise_field_dmds alt_con = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + S2 alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + annotate da_demands case_bndr case_bndr_dmd -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd - - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt_con + let !scrut_sd + | (_ :* case_bndr_sd) <- strictifyDmd case_bndr_dmd -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- DEFAULT alts. Simply add demands and discard the evaluation - -- cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) + = scrutSubDmd case_bndr_sd fld_dmds + + -- See Note [Demand on case-alternative binders] + case alt_con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length fld_dmds)) + _ -> pure () - alt_ty3 + let alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut = deferAfterPreciseException alt_ty2 | otherwise = alt_ty2 - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut + scrut_ty <- dmdAnal env scrut_sd scrut + let !res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty +-- pprTraceM "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) + pure res_ty where want_precise_field_dmds (DataAlt dc) | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc @@ -564,36 +561,32 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above want_precise_field_dmds DEFAULT = True -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 +dmdAnal' env dmd (Case scrut case_bndr _ty alts) = do + -- Case expression with multiple alternatives + alt_tys <- traverse (dmdAnalSumAlt env dmd case_bndr) alts + let lub = foldr lubDmdType botDmdType + let S2 alt_ty1 case_bndr_dmd = findBndrDmd env (lub alt_tys) case_bndr + annotate da_demands case_bndr case_bndr_dmd + scrut_ty <- dmdAnal env topSubDmd scrut + + let fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty1" <+> ppr alt_ty1 --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') +-- pprTraceM "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) + pure res_ty dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body + = dmdAnalBind NotTopLevel env dmd bind (\env -> dmdAnal env dmd body) -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'. @@ -629,34 +622,24 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] -dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] - -- Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives -dmdAnalSumAlts env dmd case_bndr (alt:alts) - = let - WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt - WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts - in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') - - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ - WithDmdType alt_ty (Alt con new_ids rhs') +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> AnalM s DmdType +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) = do + let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + rhs_ty <- dmdAnal rhs_env dmd rhs + let S2 alt_ty dmds = findBndrsDmds env rhs_ty bndrs + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + let scrut_sd + | (_ :* case_bndr_sd) <- findIdDemand alt_ty case_bndr + = scrutSubDmd case_bndr_sd dmds + case con of + DataAlt _ -> annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + _ -> pure () + annotateBndrsDemands bndrs (fieldBndrDmds scrut_sd (length dmds)) + -- pprTraceM "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) + pure alt_ty -- See Note [Demand on the scrutinee of a product case] scrutSubDmd :: SubDemand -> [Demand] -> SubDemand @@ -1005,8 +988,7 @@ dmdTransform env var sd dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) - , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs - = dmd_ty + = discardAnnotations $ dmdAnal env sd rhs -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1066,40 +1048,38 @@ dmdAnalRhsSig -> RecFlag -> AnalEnv -> SubDemand -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) + -> AnalM s (SPair AnalEnv WeakDmds) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] -dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where +dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs = do + let threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd - body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] - = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd + = unboxedWhenSmall env rec_flag (resultType_maybe id) let_sd | otherwise -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd - WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity - rhs_dmds (de_div rhs_env) rhs' - - sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) - - opts = ae_opts env - final_id = setIdDmdAndBoxSig opts id sig - !final_env = extendAnalEnv top_lvl env final_id sig + rhs_dmd_ty <- dmdAnal env rhs_dmd rhs + let + (lam_bndrs, _) = collectBinders rhs + DmdType rhs_env rhs_dmds = rhs_dmd_ty + final_rhs_dmds = finaliseArgBoxities env id threshold_arity rhs_dmds + (de_div rhs_env) lam_bndrs + -- Attach the demands to the outer lambdas of this expression + -- NB: zipWithM_, not zipWithEqualM_, in contrast to annotateBndrsDemands. + -- We might have more demands than binders (PAP), hence don't panic (#22997). + zipWithM_ (annotate da_demands) (filter isId lam_bndrs) final_rhs_dmds + + let -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason -- is really much different: When we have a recursive function, we'd @@ -1121,6 +1101,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 + sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds) + opts = ae_opts env + !final_env = extendAnalEnv top_lvl env id sig + + -- pprTraceM "dmdAnalRhsSig" (ppr id $$ ppr let_sd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) + annotateSig opts id sig + pure $! S2 final_env weak_fvs splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) @@ -1246,7 +1233,7 @@ Note [Lazy and unleashable free variables]. The implementation is easy. When analysing a join point, we can analyse its body with the demand from the entire join-binding (written -let_dmd here). +let_sd here). Another win for join points! #13543. @@ -1920,16 +1907,16 @@ positiveTopBudget (MkB n _) = n >= 0 finaliseArgBoxities :: AnalEnv -> Id -> Arity -> [Demand] -> Divergence - -> CoreExpr -> ([Demand], CoreExpr) -finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs + -> [Id] -> [Demand] +finaliseArgBoxities env fn threshold_arity rhs_dmds div bndrs -- Check for an OPAQUE function: see Note [OPAQUE pragma] -- In that case, trim off all boxity info from argument demands - -- and demand info on lambda binders + -- and demand info on lambda binders (#22502) -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] | isOpaquePragma (idInlinePragma fn) , let trimmed_rhs_dmds = map trimBoxity rhs_dmds - = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs) + = trimmed_rhs_dmds -- Check that we have enough visible binders to match the -- threshold arity; if not, we won't do worker/wrapper @@ -1940,7 +1927,7 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- It's a bit of a corner case. Anyway for now we pass on the -- unadulterated demands from the RHS, without any boxity trimming. | threshold_arity > count isId bndrs - = (rhs_dmds, rhs) + = rhs_dmds -- The normal case | otherwise -- NB: threshold_arity might be less than @@ -1950,13 +1937,12 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - (arg_dmds', set_lam_dmds arg_dmds' rhs) + arg_dmds' -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env - (bndrs, _body) = collectBinders rhs unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ] max_wkr_args = dmd_max_worker_args opts `max` unarise_arity -- This is the budget initialisation step of @@ -1968,16 +1954,16 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take threshold_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] - - get_dmd :: Id -> Demand - get_dmd bndr + arg_triples = + take threshold_arity $ + zipWith (\b dmd -> (idType b, NotMarkedStrict, add_bot_boxity dmd)) + (filter isId bndrs) + rhs_dmds + + add_bot_boxity :: Demand -> Demand + add_bot_boxity dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2034,19 +2020,6 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr - -- Attach the demands to the outer lambdas of this expression - set_lam_dmds (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) - set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co - -- This case happens for an OPAQUE function, which may look like - -- f = (\x y. blah) |> co - -- We give it strictness but no boxity (#22502) - set_lam_dmds _ e = e - -- In the OPAQUE case, the list of demands at this point might be - -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). - finaliseLetBoxity :: AnalEnv -> Type -- ^ Type of the let-bound Id @@ -2178,65 +2151,64 @@ dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> SubDemand -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs + -> AnalM s (SPair AnalEnv WeakDmds) +dmdFix top_lvl env let_sd pairs + = do sigs <- read_sigs; loop 1 (next_env sigs) sigs where - opts = ae_opts env + bndrs = map fst pairs + next_env sigs = extendAnalEnvs top_lvl env bndrs sigs + -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_pairs + read_sigs = do + annotations <- readAnn da_sigs + let init_sigs = [ botSig | _ <- bndrs ] + pure $! traverse (lookupVarEnv annotations) bndrs `orElse` init_sigs -- If fixed-point iteration does not yield a result we use this instead -- See Note [Safe abortion in the fixed-point iteration] - abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_) <- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' + abort :: AnalM s (SPair AnalEnv WeakDmds) + abort = do + S3 env' sigs' weak_fv <- step (next_env [ nopSig | _ <- bndrs ]) + -- NB: step updates the annotation + -- Note [Lazy and unleashable free variables] + let weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv) sigs' + weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs + pure $! S2 env' weak_fv' + + -- The fixed-point varies the DmdSig stored in the AnalEnv for bndrs, and + -- terminates if that annotation does not change any more. + -- For convenience, we also pass the bndr's DmdSig instead of fetching it + -- from AnalEnv on every iteration. + loop :: Int -> AnalEnv -> [DmdSig] -> AnalM s (SPair AnalEnv WeakDmds) + loop n env sigs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- sigs]) $ + loop' n env sigs + + loop' n env sigs | n == 10 = abort + | otherwise = do + S3 env' sigs' weak_fv' <- step env + -- NB: step updates the annotation + let found_fixpoint = sigs' == sigs + if found_fixpoint + then pure $! S2 env' weak_fv' + else loop (n+1) env' sigs' + + step :: AnalEnv -> AnalM s (STriple AnalEnv [DmdSig] WeakDmds) + step env = do + S2 env' weak_fv' <- foldlM do_one (S2 env emptyVarEnv) pairs + -- foldlM: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + let sigs' = expectJust "dmdFix.step" $ traverse (fmap fst . lookupSigEnv env') bndrs + -- annotation done in dmdAnalRhsSig + -- zipWithEqualM_ "dmdFix.step" (annotateSig (ae_opts env)) bndrs sigs' + pure $! S3 env' sigs' weak_fv' where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + do_one (S2 env weak_fv) (id, rhs) = do + -- pprTraceM "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) + S2 env' weak_fv1 <- dmdAnalRhsSig top_lvl Recursive env let_sd id rhs + let !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 + pure $! S2 env' weak_fv' {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2349,32 +2321,10 @@ addWeakFVs dmd_ty weak_fvs -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] -setBndrsDemandInfo (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id +annotateBndrsDemands :: HasCallStack => [Var] -> [Demand] -> AnalM s () +annotateBndrsDemands bs ds = + zipWithEqualM_ "annotateBndrsDemands" + (annotate da_demands) (filter isRuntimeVar bs) ds {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2456,7 +2406,6 @@ data AnalEnv = AE { ae_opts :: !DmdAnalOpts -- ^ Analysis options , ae_sigs :: !SigEnv - , ae_virgin :: !Bool -- ^ True on first iteration only. See Note [Initialising strictness] , ae_fam_envs :: !FamInstEnvs , ae_rec_dc :: DataCon -> IsRecDataConResult @@ -2474,15 +2423,13 @@ type SigEnv = VarEnv (DmdSig, TopLevelFlag) instance Outputable AnalEnv where ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) + [ text "ae_sigs =" <+> ppr (ae_sigs env) ]) emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv emptyAnalEnv opts fam_envs = AE { ae_opts = opts , ae_sigs = emptySigEnv - , ae_virgin = True , ae_fam_envs = fam_envs , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } @@ -2501,13 +2448,13 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv -- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> [DmdSig] -> AnalEnv +extendAnalEnvs top_lvl env vars sigs + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars sigs } -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> [DmdSig] -> SigEnv +extendSigEnvs top_lvl env vars sigs + = extendVarEnvList env (zipWith (\v s -> (v, (s, top_lvl))) vars sigs) extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv extendAnalEnv top_lvl env var sig @@ -2525,26 +2472,23 @@ addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where - go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty [] = S2 dmd_ty [] go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) + | isId b = let S2 dmd_ty1 dmds = go dmd_ty bs + S2 dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in S2 dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' + S2 dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) @@ -2636,6 +2580,7 @@ as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +TODO: Update; now we use DmdAnnotations as state See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a @@ -2734,3 +2679,28 @@ decrease because we allocate a lot fewer thunks which we immediately overwrite a also runtime for the pass is faster! Overall, good wins. -} + +--------------------------------- +-- Applying demand annotations -- +--------------------------------- + +data DmdAnnotations f = DA + { da_demands :: !(f (IdEnv Demand)) + , da_sigs :: !(f (IdEnv DmdSig)) + } + +annotateProgram :: DmdAnnotations Identity -> CoreProgram -> CoreProgram +annotateProgram anns = runIdentity . traverseBinders (Identity . annotate) + where + annotate bndr | isTyVar bndr = bndr + | otherwise = annotate_sig $ annotate_demand bndr + annotate_sig bndr + | Just sig <- lookupVarEnv (runIdentity $ da_sigs anns) bndr + = bndr `setIdDmdSig` sig + | otherwise + = bndr + annotate_demand bndr + | Just dmd <- lookupVarEnv (runIdentity $ da_demands anns) bndr + = bndr `setIdDemandInfo` dmd + | otherwise + = bndr ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.FreshenUniques ( freshenUniques ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) @@ -148,7 +149,8 @@ getCoreToDo dflags hpt_rule_base extra_vars maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase) - | phase `elem` strictnessBefore dflags = CoreDoDemand False + | phase `elem` strictnessBefore dflags + = CoreDoPasses [CoreFreshenUniques, CoreDoDemand False] maybe_strictness_before _ = CoreDoNothing @@ -169,8 +171,8 @@ getCoreToDo dflags hpt_rule_base extra_vars simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter (initGentleSimplMode dflags) hpt_rule_base - dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] + dmd_cpr_ww = if ww_on then [CoreFreshenUniques,CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreFreshenUniques,CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] demand_analyser = (CoreDoPasses ( @@ -338,7 +340,8 @@ getCoreToDo dflags hpt_rule_base extra_vars -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) (CoreDoDemand False), + runWhen (strictness || late_dmd_anal) $ CoreDoPasses + [ CoreFreshenUniques, CoreDoDemand False ], maybe_rule_check FinalPhase, @@ -517,6 +520,9 @@ doCorePass pass guts = do CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} addLateCostCentresMG guts + CoreFreshenUniques -> {-# SCC "FreshenUniques" #-} + updateBinds freshenUniques + CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts ===================================== compiler/GHC/Core/Opt/Pipeline/Types.hs ===================================== @@ -65,6 +65,7 @@ data CoreToDo -- These are diff core-to-core passes, | CorePrep | CoreAddCallerCcs | CoreAddLateCcs + | CoreFreshenUniques instance Outputable CoreToDo where ppr (CoreDoSimplify _) = text "Simplifier" @@ -92,6 +93,7 @@ instance Outputable CoreToDo where ppr (CoreDoRuleCheck {}) = text "Rule check" ppr CoreDoNothing = text "CoreDoNothing" ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + ppr CoreFreshenUniques = text "CoreFreshenUniques" pprPassDetails :: CoreToDo -> SDoc pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -514,10 +514,10 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) (subst',bndrs') = substBndrs subst bndrs args' = map (substExpr subst') args -substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src, uf_cache = cache }) -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work - = NoUnfolding + = if uf_is_value cache then evaldUnfolding else NoUnfolding | otherwise -- But keep a stable one! = seqExpr new_tmpl `seq` unf { uf_tmpl = new_tmpl } ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -62,6 +62,9 @@ module GHC.Core.Utils ( -- * unsafeEqualityProof isUnsafeEqualityCase, + -- * Traversals + traverseBinders, + -- * Dumping stuff dumpIdInfoOfProgram ) where @@ -2335,6 +2338,28 @@ locBind loc b1 b2 diffs = map addLoc diffs bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 +-- | A traversal over all 'CoreBndr's in the given 'CoreProgram'. +-- Can be instantiated at 'Const' to get a setter. +traverseBinders :: Applicative f => (CoreBndr -> f CoreBndr) -> CoreProgram -> f CoreProgram +traverseBinders f = traverse bind + where + bind (NonRec b rhs) = NonRec <$> f b <*> expr rhs + bind (Rec prs) = Rec <$> traverse (\(b, rhs) -> (,) <$> f b <*> expr rhs) prs + + expr e = case e of + Var{} -> pure e + Lit{} -> pure e + Coercion{} -> pure e + Type{} -> pure e + Tick t e' -> Tick t <$> expr e' + Cast e' co -> Cast <$> expr e' <*> pure co + Lam b body -> Lam <$> f b <*> expr body + App fun arg -> App <$> expr fun <*> expr arg + Let bs body -> Let <$> bind bs <*> expr body + Case scrut bndr ty alts -> Case <$> expr scrut <*> f bndr <*> pure ty <*> traverse alt alts + + alt (Alt con bndrs rhs) = Alt con <$> traverse f bndrs <*> expr rhs +{-# INLINE traverseBinders #-} {- ********************************************************************* * * ===================================== compiler/GHC/Data/STuple.hs ===================================== @@ -0,0 +1,44 @@ +-- | Defines a strict tuple data types, such as 'SPair'. +module GHC.Data.STuple + ( SPair(..), swap, toPair, sFirst, sSecond, sUnzip + , STriple(..), mapSSndOf3, mapSTrdOf3, toTriple + , SQuad(..), toQuad + ) where + +import GHC.Prelude + +-- | Strict pair data type +data SPair a b = S2 { sFst :: !a, sSnd :: !b } + +swap :: SPair a b -> SPair b a +swap (S2 a b) = (S2 b a) + +toPair :: SPair a b -> (a, b) +toPair (S2 a b) = (a, b) + +sFirst :: (a -> a') -> SPair a b -> SPair a' b +sFirst f (S2 a b) = S2 (f a) b + +sSecond :: (b -> b') -> SPair a b -> SPair a b' +sSecond f (S2 a b) = S2 a (f b) + +sUnzip :: [SPair a b] -> SPair [a] [b] +sUnzip = uncurry S2 . unzip . map toPair + +-- | Strict triple data type +data STriple a b c = S3 { sFstOf3 :: !a, sSndOf3 :: !b, sTrdOf3 :: !c } + +mapSSndOf3 :: (b -> b') -> STriple a b c -> STriple a b' c -- feel free to add more as needed +mapSSndOf3 f (S3 a b c) = S3 a (f b) c + +mapSTrdOf3 :: (c -> c') -> STriple a b c -> STriple a b c' -- feel free to add more as needed +mapSTrdOf3 f (S3 a b c) = S3 a b (f c) + +toTriple :: STriple a b c -> (a, b, c) +toTriple (S3 a b c) = (a, b, c) + +-- | Strict quadruple data type +data SQuad a b c d = S4 { sFstOf4 :: !a, sSndOf4 :: !b, sTrdOf4 :: !c, sFthOf4 :: !d } + +toQuad :: SQuad a b c d -> (a, b, c, d) +toQuad (S4 a b c d) = (a, b, c, d) ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -83,6 +83,7 @@ coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag CoreFreshenUniques = Just Opt_D_dump_freshen coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -118,6 +118,7 @@ data DumpFlag | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) | Opt_D_dump_call_arity | Opt_D_dump_exitify + | Opt_D_dump_freshen -- ^ FreshenUniques | Opt_D_dump_dmdanal | Opt_D_dump_dmd_signatures | Opt_D_dump_cpranal ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -1461,6 +1461,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-freshen" + (setDumpFlag Opt_D_dump_freshen) , make_dep_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_dmdanal) "Use `-ddump-dmdanal` instead" ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Utils.Misc ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipWithEqualM_, stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -135,7 +136,7 @@ import qualified Data.List.NonEmpty as NE import GHC.Exts import GHC.Stack (HasCallStack) -import Control.Monad ( guard ) +import Control.Monad import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) @@ -248,11 +249,14 @@ zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWithEqualM_ :: (HasDebugCallStack, Applicative f) => String -> (a->b->f ()) -> [a]->[b]->f () + #if !defined(DEBUG) zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = List.zipWith4 +zipWithEqualM_ _ = zipWithM_ #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -271,6 +275,10 @@ zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) + +zipWithEqualM_ msg z (a:as) (b:bs) = z a b *> zipWithEqualM_ msg z as bs +zipWithEqualM_ _ _ [] [] = pure () +zipWithEqualM_ msg _ _ _ = panic ("zipWithEqualM_: unequal lists: "++msg) #endif -- | 'filterByList' takes a list of Bools and a list of some elements and ===================================== compiler/ghc.cabal.in ===================================== @@ -333,6 +333,7 @@ Library GHC.Core.ConLike GHC.Core.DataCon GHC.Core.FamInstEnv + GHC.Core.FreshenUniques GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint @@ -431,6 +432,7 @@ Library GHC.Data.Stream GHC.Data.Strict GHC.Data.StringBuffer + GHC.Data.STuple GHC.Data.TrieMap GHC.Data.Unboxed GHC.Data.UnionFind ===================================== docs/users_guide/debugging.rst ===================================== @@ -481,6 +481,13 @@ subexpression elimination pass. Dump static argument transformation pass output (see :ghc-flag:`-fstatic-argument-transformation`) +.. ghc-flag:: -ddump-freshen + :shortdesc: Dump output after freshening uniques + :type: dynamic + + Dump the Core after each run of FreshenUniques, which makes sure that each + binder's Unique is indeed globally unique. + .. ghc-flag:: -ddump-worker-wrapper :shortdesc: Dump worker-wrapper output :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4f29a7236c9c9fafbcc5c966ce168ee1db0d663...6c9e9f420d8ae5ac5efcba758e08824f8a1d5c13 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4f29a7236c9c9fafbcc5c966ce168ee1db0d663...6c9e9f420d8ae5ac5efcba758e08824f8a1d5c13 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 21:13:47 2024 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Sat, 06 Jan 2024 16:13:47 -0500 Subject: [Git][ghc/ghc][wip/T19520] Remove VoidRep from PrimRep, introduce PrimOrVoidRep Message-ID: <6599c28b68f1b_952778dfa7c5856@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T19520 at Glasgow Haskell Compiler / GHC Commits: bee964e1 by Krzysztof Gogolewski at 2024-01-06T22:13:07+01:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 25 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.Demand import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) @@ -857,7 +857,8 @@ primOpSig op GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep + = ReturnsVoid + | ReturnsPrim PrimRep | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value @@ -867,8 +868,11 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) | isUnboxedTupleTyCon tc -> ReturnsTuple | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -61,7 +61,7 @@ make_constr_itbls interp profile cons = where mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + let rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Cmm.Utils( import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -97,7 +97,6 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +135,10 @@ primElemRepCmmType Word64ElemRep = b64 primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +155,8 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -126,8 +126,9 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, + isGcPtrRep, primRepSizeB, primRepSizeW64_B, primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, @@ -1532,17 +1533,18 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -} --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, +-- | A 'PrimRep' is an abstraction of a /non-void/ type. +-- (Use 'PrimRepOrVoidRep' if you want void types too.) +-- It contains information that the code generator needs +-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep -- Unpacking of sum types is only supported since 9.6.1 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value #else - | BoxedRep !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep !(Maybe Levity) -- ^ Boxed, heap value #endif | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -1560,6 +1562,9 @@ data PrimRep | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1580,58 +1585,52 @@ instance Outputable PrimElemRep where ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1676,7 +1675,6 @@ primRepSizeB platform = \case DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep -- | Like primRepSizeB but assumes pointers/words are 8 words wide. @@ -1699,7 +1697,6 @@ primRepSizeW64_B = \case DoubleRep -> dOUBLE_SIZE AddrRep -> 8 BoxedRep{} -> 8 - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeW64_B rep primElemRepSizeB :: Platform -> PrimElemRep -> Int ===================================== compiler/GHC/HsToCore/Foreign/Utils.hs ===================================== @@ -57,7 +57,7 @@ primTyDescChar :: Platform -> Type -> Char primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' ===================================== compiler/GHC/Stg/Lift/Analysis.hs ===================================== @@ -418,7 +418,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -377,16 +377,10 @@ lintStgAppReps fun args = do match_args (Nothing:_) _ = return () match_args (_) (Nothing:_) = return () match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left) - -- Common case, reps are exactly the same + -- Common case, reps are exactly the same (perhaps void) | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep (empty list) - -- Note typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. - | isVoidRep actual_rep && isVoidRep expected_rep - = match_args actual_reps_left expected_reps_left - -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep. -- We check for that here with primRepCompatible | primRepsCompatible platform actual_rep expected_rep @@ -409,8 +403,6 @@ lintStgAppReps fun args = do -- text "expected reps:" <> ppr arg_ty_reps $$ text "unarised?:" <> ppr (lf_unarised lf)) where - isVoidRep [] = True - isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which -- will result in a lint failure in match_args. ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.Stg.Syntax ( stgArgType, stgArgRep, stgArgRep1, + stgArgRepU, stgArgRep_maybe, stgCaseBndrInScope, @@ -80,7 +81,7 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -90,7 +91,7 @@ import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable @@ -177,10 +178,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -199,11 +200,17 @@ stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep_maybe :: StgArg -> Maybe [PrimRep] stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) --- | Assumes that the argument has one PrimRep, which holds after unarisation. +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -stgArgRep1 :: StgArg -> PrimRep +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep stgArgRep1 ty = typePrimRep1 (stgArgType ty) +-- | Assumes that the argument has exactly one PrimRep. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -373,6 +373,7 @@ STG programs after unarisation have these invariants: 2. No unboxed tuple binders. Tuples only appear in return position. 3. Binders and literals always have zero (for void arguments) or one PrimRep. + (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.) 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments. This means that it's safe to wrap `StgArg`s of DataCon applications with @@ -607,13 +608,12 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -814,7 +814,7 @@ mapSumIdBinders alt_bndr args rhs rho0 mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -860,7 +860,7 @@ mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -922,8 +922,8 @@ mkUbxSum dc ty_args args0 us castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= stgArgRep1 arg - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout @@ -529,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (stgArgRep1 e) + arg_ty e = primRepCmmType platform (stgArgRepU e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -540,12 +540,14 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - let non_void VoidRep = False - non_void _ = True + let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep + rep_to_maybe VoidRep = Nothing + rep_to_maybe (NVRep rep) = Just rep + ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map stgArgRep1 es) + (mapMaybe (rep_to_maybe . stgArgRep1) es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -928,7 +930,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . idPrimRep + let bndr_ty = primRepCmmType platform . idPrimRepU tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -944,7 +946,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ idPrimRep arg)] + , not (isZeroBitTy $ idType arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -1378,10 +1380,10 @@ generatePrimCall d s p target _mb_unit _result_ty args layoutNativeCall profile NativePrimCall 0 - (primRepCmmType platform . stgArgRep1) + (primRepCmmType platform . stgArgRepU) nv_args - prim_args_offsets = mapFst stgArgRep1 args_offsets + prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 @@ -1457,7 +1459,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- ArgRep of what was actually pushed. pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] pargs _ [] = return [] pargs d (aa@(StgVarArg a):az) | Just t <- tyConAppTyCon_maybe (idType a) @@ -1470,7 +1472,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) + return ((code, NVRep AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az return ((code_a, stgArgRep1 aa) : rest) @@ -1483,8 +1485,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x + | VoidRep:xs <- a_reps_pushed_r_to_l = reverse xs | otherwise = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" @@ -1494,10 +1495,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- d_after_args is the stack depth once the args are on. -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) + r_rep = maybe_getCCallReturnRep result_ty {- Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call @@ -1570,10 +1568,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- this is a V (tag). r_sizeW = repSizeWords platform r_rep d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) -- generate the marshalling code we're going to call @@ -1611,17 +1608,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) + `snocOL` RETURN (toArgRepOrV platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) = case r of - VoidRep -> FFIVoid IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> FFISInt8 @@ -1668,7 +1665,7 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- --- to Just IntRep +-- to NVRep IntRep -- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert @@ -1676,16 +1673,16 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- --- to Nothing +-- to VoidRep -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) in case typePrimRep r_ty of - [] -> Nothing - [rep] -> Just rep + [] -> VoidRep + [rep] -> NVRep rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2131,10 +2128,10 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -2171,7 +2168,7 @@ mkSlideW !n !ws atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (stgArgRep1 e) +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -253,8 +253,8 @@ cgDataCon mn data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) ] ===================================== compiler/GHC/StgToCmm/ArgRep.hs ===================================== @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ module GHC.StgToCmm.ArgRep ( import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -68,7 +68,6 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ toArgRep platform rep = case rep of 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ argRepSizeW platform = \case ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -382,7 +382,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -18,7 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -176,24 +176,27 @@ assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (stgArgRep1 arg', arg')) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -205,4 +205,4 @@ idToReg :: Platform -> NonVoid Id -> LocalReg -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -488,7 +488,7 @@ accurate update would complexify the implementation and doesn't seem worth it. -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -522,9 +522,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -330,8 +330,8 @@ getArgRepsAmodes args = do where getArgRepAmode platform arg = case stgArgRep1 arg of VoidRep -> return (V, Nothing) - rep -> do expr <- getArgAmode (NonVoid arg) - return (toArgRep platform rep, Just expr) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -438,7 +438,6 @@ mkVirtHeapOffsetsWithPadding -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -520,13 +519,13 @@ mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -52,7 +52,6 @@ cgLit (LitString s) = -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1720,7 +1720,7 @@ emitPrimOp cfg primop = -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do regs <- case result_info of - ReturnsPrim VoidRep -> pure [] + ReturnsVoid -> pure [] ReturnsPrim rep -> do reg <- newTemp (primRepCmmType platform rep) pure [reg] ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -615,7 +615,7 @@ tickySlowCall lf_info args = do tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform . stgArgRep1) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/StgToJS/Arg.hs ===================================== @@ -120,7 +120,7 @@ genStaticArg a = case a of Nothing -> reg Just expr -> unfloated expr where - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -162,7 +162,7 @@ genArg a = case a of where -- if our argument is a joinid, it can be an unboxed tuple r :: HasDebugCallStack => JSRep - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -351,7 +351,7 @@ genBody ctx startReg args e typ = do -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -20,6 +20,7 @@ module GHC.StgToJS.Utils , typeJSRep , unaryTypeJSRep , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType , primRepSize , mkArityTag @@ -196,10 +197,9 @@ typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep -unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut) +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep -primRepToJSRep VoidRep = VoidV primRepToJSRep (BoxedRep _) = PtrV primRepToJSRep IntRep = IntV primRepToJSRep Int8Rep = IntV @@ -216,6 +216,10 @@ primRepToJSRep FloatRep = DoubleV primRepToJSRep DoubleRep = DoubleV primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,7 +1525,6 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. - -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys -- And then get the actual size of the unpacked constructor. rep_size = sum $ map primRepSizeW64_B prim_reps ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -11,11 +11,11 @@ module GHC.Types.RepType isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type @@ -38,7 +38,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -80,15 +80,6 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty - -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts @@ -129,7 +120,10 @@ countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = (length (typePrimRep arg) `max` 1) + + countFunRepArgs (n - 1) res + -- If typePrimRep returns [] that means a void arg, + -- and we count 1 for that | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -308,7 +302,6 @@ repSlotTy reps = case reps of _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -391,8 +384,7 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -441,18 +433,37 @@ See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) + +For example: + typePrimRep Int# = [IntRep] + typePrimRep Int = [LiftedRep] + typePrimRep (# Int#, Int# #) = [IntRep,IntRep] + typePrimRep (# #) = [] + typePrimRep (State# s) = [] + +After the unariser, all identifiers have at most one PrimRep +(that is, the [PrimRep] for each identifier is empty or a singleton list). +More precisely: typePrimRep1 will succeed (not crash) on every binder +and argument type. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +Thus, we have -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +1. typePrimRep :: Type -> [PrimRep] + which returns the list + +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. typePrimRep1 :: Type -> PrimOrVoidRep + data PrimOrVoidRep = VoidRep | NVRep PrimRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1, +which have analogous preconditions. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -546,17 +557,22 @@ typePrimRep ty = kindPrimRep (text "typePrimRep" <+> typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -567,15 +583,6 @@ tyConPrimRep tc where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -603,8 +610,6 @@ kindPrimRep_maybe ki -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -617,8 +622,7 @@ runtimeRepPrimRep doc rr_ty -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -634,7 +638,6 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bee964e1a37772961f58be233b611c1eee3fc315 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bee964e1a37772961f58be233b611c1eee3fc315 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sat Jan 6 23:23:00 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 06 Jan 2024 18:23:00 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix VoidRep handling in ghci debugger Message-ID: <6599e0d44fabb_952773c2e32461686@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 67dbcc0a by Krzysztof Gogolewski at 2024-01-05T02:07:18-05:00 Fix VoidRep handling in ghci debugger 'go' inside extractSubTerms was giving a bad result given a VoidRep, attempting to round towards the next multiple of 0. I don't understand much about the debugger but the code should be better than it was. Fixes #24306 - - - - - 90ea574e by Krzysztof Gogolewski at 2024-01-05T02:07:54-05:00 VoidRep-related refactor * In GHC.StgToByteCode, replace bcIdPrimId with idPrimRep, bcIdArgRep with idArgRep, atomPrimRep with stgArgRep1. All of them were duplicates. * In GHC.Stg.Unarise, we were converting a PrimRep to a Type and back to PrimRep. Remove the calls to primRepToType and typePrimRep1 which cancel out. * In GHC.STG.Lint, GHC.StgToCmm, GHC.Types.RepType we were filtering out VoidRep from the result of typePrimRep. But typePrimRep never returns VoidRep - remove the filtering. - - - - - 4dcb3ecc by brian at 2024-01-06T18:22:54-05:00 Add unaligned Addr# primops Implements CLC proposal #154: https://github.com/haskell/core-libraries-committee/issues/154 * add unaligned addr primops * add tests * accept tests * add documentation * fix js primops * uncomment in access ops * use Word64 in tests * apply suggestions * remove extra file * move docs * remove random options * use setByteArray# primop * better naming * update base-exports test * add base-exports for other architectures - - - - - e1f4e1e4 by Krzysztof Gogolewski at 2024-01-06T18:22:55-05:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs - docs/users_guide/9.10.1-notes.rst - libraries/ghc-prim/changelog.md - + testsuite/tests/ghci.debugger/scripts/T24306.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c89c74905dc197b3931b23aafe04b5c79c7439dd...e1f4e1e4cfa665076b755a371d543020deedd8cb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c89c74905dc197b3931b23aafe04b5c79c7439dd...e1f4e1e4cfa665076b755a371d543020deedd8cb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 00:09:31 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Sat, 06 Jan 2024 19:09:31 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] Tidying up Message-ID: <6599ebbbd341f_9527750f8bec66736@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 7b785ac8 by Simon Peyton Jones at 2024-01-07T00:09:00+00:00 Tidying up - - - - - 7 changed files: - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/typecheck/should_fail/tcfail175.hs Changes: ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -638,7 +638,7 @@ tcPolyCheck prag_fn ; (wrap_gen, (wrap_res, matches')) <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> setSrcSpanA bind_loc $ - tcFunBindMatches ctxt mono_name mult matches invis_pat_tys rho_ty + tcFunBindMatches ctxt mono_name mult matches invis_pat_tys (mkCheckExpType rho_ty) -- We make a funny AbsBinds, abstracting over nothing, -- just so we have somewhere to put the SpecPrags. ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Tc.Gen.Expr tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, - tcPolyLExpr, tcPolyLExprNC, tcPolyExpr, tcExpr, + tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -100,7 +100,6 @@ import qualified Data.List.NonEmpty as NE ************************************************************************ -} - tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn -- Expression to type check -> TcSigmaType -- Expected type (could be a polytype) @@ -129,6 +128,104 @@ tcPolyLExprNC (L loc expr) res_ty do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } + +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr e (Infer inf) = tcExpr e (Infer inf) +tcPolyExpr e (Check ty) = tcPolyExprCheck e (Left ty) + +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) +tcPolyLExprSig (L loc expr) sig + = setSrcSpanA loc $ addExprCtxt expr $ + do { expr' <- tcPolyExprCheck expr (Right sig) + ; return (L loc expr') } + +----------------- +tcPolyExprCheck :: HsExpr GhcRn + -> Either TcSigmaType TcCompleteSig + -> TcM (HsExpr GhcTc) +-- tcPolyExpCheck deals with the special case for HsLam, in case the pushed-down +-- type is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int +-- +-- The (Either TcSigmaType TcCompleteSig) deals with: +-- Left ty: (f e) pushes f's argument type `ty` into `e` +-- Right sig: (e :: sig) pushes `sig` into `e` +-- The Either stuff is entirely local to this function and its immeidate callers. + +tcPolyExprCheck expr res_ty + = outer_skolemise res_ty $ \pat_tys rho_ty -> + let + -- tc_body is a little loop that looks past parentheses + tc_body (HsPar x (L loc e)) + = setSrcSpanA loc $ + do { e' <- tc_body e + ; return (HsPar x (L loc e')) } + + -- The special case for lambda: go to tcLambdaPatches, passing pat_tys + tc_body e@(HsLam x lam_variant matches) + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys + (mkCheckExpType rho_ty) + -- NB: tcLamdaMatches concludes with deep skolemisation, + -- if DeepSubsumption is on; hence no need to do that here + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + + -- The general case: just do deep skolemisation if necessary, + -- before handing off to tcExpr + tc_body e + = do { ds_flag <- getDeepSubsumptionFlag + ; inner_skolemise ds_flag rho_ty $ \rho_ty' -> + tcExpr e (mkCheckExpType rho_ty') } + in tc_body expr + where + -- outer_skolemise is used always + -- It only does shallow skolemisation + outer_skolemise :: Either TcSigmaType TcCompleteSig + -> ([ExpPatType] -> TcRhoType -> TcM (HsExpr GhcTc)) + -> TcM (HsExpr GhcTc) + outer_skolemise (Left ty) thing_inside + = do { (wrap, expr') <- tcSkolemise Shallow GenSigCtxt ty $ \rho_ty -> + thing_inside [] rho_ty + ; return (mkHsWrap wrap expr') } + outer_skolemise (Right sig) thing_inside + = do { (wrap, expr') <- tcSkolemiseCompleteSig sig thing_inside + ; return (mkHsWrap wrap expr') } + + -- inner_skolemise is used when we do not have a lambda + -- With deep skolemisation we must remember to deeply skolemise + -- after the (always-shallow) tcSkolemiseCompleteSig + inner_skolemise :: DeepSubsumptionFlag -> TcRhoType + -> (TcRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc) + inner_skolemise Shallow rho_ty thing_inside + = -- We have already done shallow skolemisation, so nothing further to do + thing_inside rho_ty + inner_skolemise Deep rho_ty thing_inside + = -- Try deep skolemisation + do { (wrap, expr') <- tcSkolemise Deep ctxt rho_ty thing_inside + ; return (mkHsWrap wrap expr') } + + ctxt = case res_ty of + Left {} -> GenSigCtxt + Right sig -> sig_ctxt sig + + +{- ********************************************************************* +* * + tcExpr: the main expression typechecker +* * +********************************************************************* -} + +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +-- Infer a *rho*-type. The return type is always instantiated. +tcInferRho (L loc expr) + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } + +tcInferRhoNC (L loc expr) + = setSrcSpanA loc $ + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } + --------------- tcCheckMonoExpr, tcCheckMonoExprNC :: LHsExpr GhcRn -- Expression to type check @@ -138,6 +235,7 @@ tcCheckMonoExpr, tcCheckMonoExprNC tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) +--------------- tcMonoExpr, tcMonoExprNC :: LHsExpr GhcRn -- Expression to type check -> ExpRhoType -- Expected type @@ -156,51 +254,6 @@ tcMonoExprNC (L loc expr) res_ty ; return (L loc expr') } --------------- -tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) --- Infer a *rho*-type. The return type is always instantiated. -tcInferRho (L loc expr) - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] - do { (expr', rho) <- tcInfer (tcExpr expr) - ; return (L loc expr', rho) } - -tcInferRhoNC (L loc expr) - = setSrcSpanA loc $ - do { (expr', rho) <- tcInfer (tcExpr expr) - ; return (L loc expr', rho) } - - -{- ********************************************************************* -* * - tcExpr: the main expression typechecker -* * -********************************************************************* -} - -tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) - --- We begin with a special case for HsLam, in case the pushed-down type --- is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int -tcPolyExpr e@(HsLam x lam_variant matches) res_ty - = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty - ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } - --- This HsPar case means that the lambda can be wrapped in parens -tcPolyExpr (HsPar x expr) res_ty - = do { expr' <- tcPolyLExprNC expr res_ty - ; return (HsPar x expr') } - --- Otherwise we skolemise the expected type, perhaps deeply --- if DeepSkolemisation is on, and then do tcExpr -tcPolyExpr expr exp_ty@(Infer {}) - = do { traceTc "tcPolyExpr:infer" (ppr exp_ty) - ; tcExpr expr exp_ty } -tcPolyExpr expr (Check ty) - = do { traceTc "tcPolyExpr:check" (ppr ty) - ; ds_flag <- getDeepSubsumptionFlag - ; (wrap,expr') <- tcSkolemise ds_flag GenSigCtxt ty $ \rho_ty -> - tcExpr expr (mkCheckExpType rho_ty) - ; return $ mkHsWrap wrap expr' } - tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- Use tcApp to typecheck applications, which are treated specially ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -5,6 +5,7 @@ import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR , SyntaxOpType , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.BasicTypes( TcCompleteSig ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) import GHC.Hs.Extension ( GhcRn, GhcTc ) @@ -23,7 +24,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) -tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -29,8 +29,7 @@ module GHC.Tc.Gen.Head , addHeadCtxt, addExprCtxt, addFunResCtxt ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprNC ) -import {-# SOURCE #-} GHC.Tc.Gen.Match( tcLambdaMatches ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) import GHC.Prelude import GHC.Hs @@ -980,26 +979,10 @@ tcExprWithSig expr hs_ty loc = getLocA (dropWildCards hs_ty) tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) -tcExprSig _ (TcPatSynSig sig) = pprPanic "tcExprSig" (ppr sig) - +tcExprSig _ (TcPatSynSig sig) = pprPanic "tcExprSig" (ppr sig) tcExprSig expr (TcCompleteSig sig) - = do { (wrap, expr') <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> - tc_body invis_pat_tys rho_ty - ; return (mkLHsWrap wrap expr', idType (sig_bndr sig)) } - where - tc_body :: [ExpPatType] -> ExpRhoType -> TcM (LHsExpr GhcTc) - tc_body pat_tys rho_ty = go expr - where - -- Look for (\@a -> blah), in case we have - -- (\@a -> blah) :: forall b. woo - go (L loc e@(HsLam x lam_variant matches)) - = setSrcSpanA loc $ - do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys rho_ty - ; return (L loc $ mkHsWrap wrap $ HsLam x lam_variant matches') } - go (L _ (HsPar _ expr)) = go expr - go expr -- Even though we have skolemised, call tcCheckPolyExpr so that - -- if we need to /deeply/ skolemise, we will do so (in tcPolyExpr). - = tcPolyLExprNC expr rho_ty + = do { expr' <- tcPolyLExprSig expr sig + ; return (expr', idType (sig_bndr sig)) } tcExprSig expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc })) = setSrcSpan loc $ -- Sets the location for the implication constraint ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -1,5 +1,5 @@ module GHC.Tc.Gen.Match where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, HsExpr, HsLamVariant, Mult ) +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( UserTypeCtxt ) @@ -18,9 +18,3 @@ tcFunBindMatches :: UserTypeCtxt -> Name -> [ExpPatType] -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) - -tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -384,6 +384,9 @@ matchExpectedFunTys :: forall a. -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -- +-- Unconditionally concludes by skolemising any trailing invisible +-- binders and, if DeepSubsumption is on, it does so deeply. +-- -- Postcondition: -- If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{} -- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{} @@ -1525,7 +1528,7 @@ tcSkolemiseGeneral ds_flag ctxt expected_ty thing_inside -- often empty, in which case mkWpLet is a no-op tcSkolemiseCompleteSig :: TcCompleteSig - -> ([ExpPatType] -> ExpRhoType -> TcM result) + -> ([ExpPatType] -> TcRhoType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- See Note [Skolemisation] for the differences between @@ -1536,11 +1539,10 @@ tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = lo = setSrcSpan loc $ -- Sets the location for the implication constraint do { tcSkolemiseGeneral Shallow ctxt (idType poly_id) $ \tv_prs rho_ty -> tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ - thing_inside (map (mkInvisExpPatType . snd) tv_prs) - (mkCheckExpType rho_ty) } + thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty } tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) + -> (TcRhoType -> TcM result) -> TcM (HsWrapper, result) tcSkolemise ds_flag ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case ===================================== testsuite/tests/typecheck/should_fail/tcfail175.hs ===================================== @@ -1,7 +1,7 @@ -- Crashed GHC 6.6! -- #1153 - + module ShouldFail where eval :: Int -> String -> String -> String View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b785ac8bd821337b2100d130d28f639a63238e6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b785ac8bd821337b2100d130d28f639a63238e6 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 04:03:44 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 06 Jan 2024 23:03:44 -0500 Subject: [Git][ghc/ghc][master] Add unaligned Addr# primops Message-ID: <659a22a0deb69_95277b1379cc73879@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: eaf72479 by brian at 2024-01-06T23:03:09-05:00 Add unaligned Addr# primops Implements CLC proposal #154: https://github.com/haskell/core-libraries-committee/issues/154 * add unaligned addr primops * add tests * accept tests * add documentation * fix js primops * uncomment in access ops * use Word64 in tests * apply suggestions * remove extra file * move docs * remove random options * use setByteArray# primop * better naming * update base-exports test * add base-exports for other architectures - - - - - 12 changed files: - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - docs/users_guide/9.10.1-notes.rst - libraries/ghc-prim/changelog.md - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/primops/should_run/UnalignedAddrPrimOps.hs - + testsuite/tests/primops/should_run/UnalignedAddrPrimOps.stdout - testsuite/tests/primops/should_run/all.T - utils/genprimopcode/AccessOps.hs Changes: ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -471,6 +471,98 @@ emitPrimOp cfg primop = ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> doIndexOffAddrOp Nothing b64 res args +-- IndexWord8OffAddrAsXXX + + IndexOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + IndexOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + IndexOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f32 b8 res args + IndexOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f64 b8 res args + IndexOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + IndexOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + IndexOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + IndexOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + IndexOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + IndexOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + IndexOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + +-- ReadWord8OffAddrAsXXX, identical to IndexWord8OffAddrAsXXX + + ReadOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_8ToWord platform)) b8 b8 res args + ReadOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs (Just (mo_u_32ToWord platform)) b32 b8 res args + ReadOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f32 b8 res args + ReadOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing f64 b8 res args + ReadOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing (bWord platform) b8 res args + ReadOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + ReadOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + ReadOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + ReadOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b16 b8 res args + ReadOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b32 b8 res args + ReadOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doIndexOffAddrOpAs Nothing b64 b8 res args + +-- WriteWord8ArrayAsXXX + WriteOffAddrOp_Word8AsChar -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo8 platform)) b8 res args + WriteOffAddrOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp (Just (mo_WordTo32 platform)) b8 res args + WriteOffAddrOp_Word8AsInt -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + WriteOffAddrOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> + doWriteOffAddrOp Nothing b8 res args + -- IndexXXXArray IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -832,6 +832,51 @@ genPrim prof bound ty op = case op of WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off32 o i) v WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_u64 a (off64 o i) h l + IndexOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + IndexOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + IndexOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + IndexOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + IndexOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + IndexOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + ReadOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + ReadOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + ReadOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + ReadOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + ReadOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + ReadOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + WriteOffAddrOp_Word8AsChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word8AsWideChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsWord -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + WriteOffAddrOp_Word8AsAddr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_addr a (off8 o i) va vo + WriteOffAddrOp_Word8AsFloat -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f32 a (off8 o i) v + WriteOffAddrOp_Word8AsDouble -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f64 a (off8 o i) v + WriteOffAddrOp_Word8AsStablePtr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_stableptr a (off8 o i) va vo + WriteOffAddrOp_Word8AsInt16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i16 a (off8 o i) v + WriteOffAddrOp_Word8AsInt32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_i64 a (off8 o i) h l + WriteOffAddrOp_Word8AsWord16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u16 a (off8 o i) v + WriteOffAddrOp_Word8AsWord32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + WriteOffAddrOp_Word8AsWord64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_u64 a (off8 o i) h l + ------------------------------- Mutable variables -------------------------------------- NewMutVarOp -> \[r] [x] -> pure $ PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> pure $ PrimInline $ r |= m .^ "val" ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -169,6 +169,29 @@ Runtime system exported by ``GHC.Exts``, but with a different type, as described in the notes for ``base`` above. +- New primops for unaligned ``Addr#`` access. + These primops will be emulated on platforms that don't support unaligned access. + These primops take the form + + .. code-block:: haskell + + indexWord8OffAddrAs :: Addr# -> Int# -> # + readWord8OffAddrAs :: Addr# -> Int# -> State# s -> (# State# s, # #) + writeWord8OffAddrAs :: Addr# -> Int# -> # -> State# s -> State# s + + where ```` is one of: + + - ``Word`` + - ``Word{16,32,64}`` + - ``Int`` + - ``Int{16,32,64,}`` + - ``Char`` + - ``WideChar`` + - ``Addr`` + - ``Float`` + - ``Double`` + - ``StablePtr`` + ``ghc`` library ~~~~~~~~~~~~~~~ ===================================== libraries/ghc-prim/changelog.md ===================================== @@ -2,6 +2,54 @@ - Shipped with GHC 9.10.1 +- Add unaligned addr access primops. These primops will be emulated on platforms that don't support unaligned access. + + readWord8OffAddrAsChar# :: Addr# -> Int# -> State# s -> (# State# s, Char# #) + readWord8OffAddrAsAddr# :: Addr# -> Int# -> State# s -> (# State# s, Addr# #) + readWord8OffAddrAsFloat# :: Addr# -> Int# -> State# s -> (# State# s, Float# #) + readWord8OffAddrAsDouble# :: Addr# -> Int# -> State# s -> (# State# s, Double# #) + readWord8OffAddrAsStablePtr# :: Addr# -> Int# -> State# s -> (# State# s, StablePtr# #) + readWord8OffAddrAsInt16# :: Addr# -> Int# -> State# s -> (# State# s, Int16# #) + readWord8OffAddrAsInt32# :: Addr# -> Int# -> State# s -> (# State# s, Int32# #) + readWord8OffAddrAsInt64# :: Addr# -> Int# -> State# s -> (# State# s, Int64# #) + readWord8OffAddrAsInt# :: Addr# -> Int# -> State# s -> (# State# s, Int# #) + + readWord8OffAddrAsWord16# :: Addr# -> Int# -> State# s -> (# State# s, Word16# #) + readWord8OffAddrAsWord32# :: Addr# -> Int# -> State# s -> (# State# s, Word32# #) + readWord8OffAddrAsWord64# :: Addr# -> Int# -> State# s -> (# State# s, Word64# #) + readWord8OffAddrAsWord# :: Addr# -> Int# -> State# s -> (# State# s, Word# #) + + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + + writeWord8OffAddrAsChar# :: Addr# -> Int# -> Char# -> State# s -> State# s + writeWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# -> State# s -> State# s + writeWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# -> State# s -> State# s + writeWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# -> State# s -> State# s + writeWord8OffAddrAsStablePtr# :: Addr# -> Int# -> StablePtr# -> State# s -> State# s + + writeWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# -> State# s -> State# s + writeWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# -> State# s -> State# s + writeWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# -> State# s -> State# s + writeWord8OffAddrAsInt# :: Addr# -> Int# -> Int# -> State# s -> State# s + + writeWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# -> State# s -> State# s + writeWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# -> State# s -> State# s + writeWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# -> State# s -> State# s + writeWord8OffAddrAsWord# :: Addr# -> Int# -> Word# -> State# s -> State# s + - The `unsafeThawByteArray#` primop was added, serving as a inverse to the existing `unsafeFreezeByteArray#` primop (see #22710). ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -3883,6 +3883,20 @@ module GHC.Base where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -4443,6 +4457,20 @@ module GHC.Base where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -4860,6 +4888,20 @@ module GHC.Base where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d @@ -5964,6 +6006,20 @@ module GHC.Exts where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -6500,6 +6556,20 @@ module GHC.Exts where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -6918,6 +6988,20 @@ module GHC.Exts where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -3883,6 +3883,20 @@ module GHC.Base where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -4443,6 +4457,20 @@ module GHC.Base where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -4860,6 +4888,20 @@ module GHC.Base where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d @@ -5933,6 +5975,20 @@ module GHC.Exts where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -6469,6 +6525,20 @@ module GHC.Exts where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -6887,6 +6957,20 @@ module GHC.Exts where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -3886,6 +3886,20 @@ module GHC.Base where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -4446,6 +4460,20 @@ module GHC.Base where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -4863,6 +4891,20 @@ module GHC.Base where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d @@ -6113,6 +6155,20 @@ module GHC.Exts where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -6649,6 +6705,20 @@ module GHC.Exts where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -7067,6 +7137,20 @@ module GHC.Exts where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -3883,6 +3883,20 @@ module GHC.Base where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -4443,6 +4457,20 @@ module GHC.Base where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -4860,6 +4888,20 @@ module GHC.Base where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d @@ -5964,6 +6006,20 @@ module GHC.Exts where indexWord8ArrayAsWord8X32# :: ByteArray# -> Int# -> Word8X32# indexWord8ArrayAsWord8X64# :: ByteArray# -> Int# -> Word8X64# indexWord8OffAddr# :: Addr# -> Int# -> Word8# + indexWord8OffAddrAsAddr# :: Addr# -> Int# -> Addr# + indexWord8OffAddrAsChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsDouble# :: Addr# -> Int# -> Double# + indexWord8OffAddrAsFloat# :: Addr# -> Int# -> Float# + indexWord8OffAddrAsInt# :: Addr# -> Int# -> Int# + indexWord8OffAddrAsInt16# :: Addr# -> Int# -> Int16# + indexWord8OffAddrAsInt32# :: Addr# -> Int# -> Int32# + indexWord8OffAddrAsInt64# :: Addr# -> Int# -> Int64# + indexWord8OffAddrAsStablePtr# :: forall a. Addr# -> Int# -> StablePtr# a + indexWord8OffAddrAsWideChar# :: Addr# -> Int# -> Char# + indexWord8OffAddrAsWord# :: Addr# -> Int# -> Word# + indexWord8OffAddrAsWord16# :: Addr# -> Int# -> Word16# + indexWord8OffAddrAsWord32# :: Addr# -> Int# -> Word32# + indexWord8OffAddrAsWord64# :: Addr# -> Int# -> Word64# indexWord8OffAddrAsWord8X16# :: Addr# -> Int# -> Word8X16# indexWord8OffAddrAsWord8X32# :: Addr# -> Int# -> Word8X32# indexWord8OffAddrAsWord8X64# :: Addr# -> Int# -> Word8X64# @@ -6500,6 +6556,20 @@ module GHC.Exts where readWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> State# d -> (# State# d, Word8X64# #) readWord8OffAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8# #) + readWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Addr# #) + readWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Double# #) + readWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Float# #) + readWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int# #) + readWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int16# #) + readWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int32# #) + readWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Int64# #) + readWord8OffAddrAsStablePtr# :: forall d a. Addr# -> Int# -> State# d -> (# State# d, StablePtr# a #) + readWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Char# #) + readWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word# #) + readWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word16# #) + readWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word32# #) + readWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word64# #) readWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X16# #) readWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X32# #) readWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> State# d -> (# State# d, Word8X64# #) @@ -6918,6 +6988,20 @@ module GHC.Exts where writeWord8ArrayAsWord8X32# :: forall d. MutableByteArray# d -> Int# -> Word8X32# -> State# d -> State# d writeWord8ArrayAsWord8X64# :: forall d. MutableByteArray# d -> Int# -> Word8X64# -> State# d -> State# d writeWord8OffAddr# :: forall d. Addr# -> Int# -> Word8# -> State# d -> State# d + writeWord8OffAddrAsAddr# :: forall d. Addr# -> Int# -> Addr# -> State# d -> State# d + writeWord8OffAddrAsChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsDouble# :: forall d. Addr# -> Int# -> Double# -> State# d -> State# d + writeWord8OffAddrAsFloat# :: forall d. Addr# -> Int# -> Float# -> State# d -> State# d + writeWord8OffAddrAsInt# :: forall d. Addr# -> Int# -> Int# -> State# d -> State# d + writeWord8OffAddrAsInt16# :: forall d. Addr# -> Int# -> Int16# -> State# d -> State# d + writeWord8OffAddrAsInt32# :: forall d. Addr# -> Int# -> Int32# -> State# d -> State# d + writeWord8OffAddrAsInt64# :: forall d. Addr# -> Int# -> Int64# -> State# d -> State# d + writeWord8OffAddrAsStablePtr# :: forall a d. Addr# -> Int# -> StablePtr# a -> State# d -> State# d + writeWord8OffAddrAsWideChar# :: forall d. Addr# -> Int# -> Char# -> State# d -> State# d + writeWord8OffAddrAsWord# :: forall d. Addr# -> Int# -> Word# -> State# d -> State# d + writeWord8OffAddrAsWord16# :: forall d. Addr# -> Int# -> Word16# -> State# d -> State# d + writeWord8OffAddrAsWord32# :: forall d. Addr# -> Int# -> Word32# -> State# d -> State# d + writeWord8OffAddrAsWord64# :: forall d. Addr# -> Int# -> Word64# -> State# d -> State# d writeWord8OffAddrAsWord8X16# :: forall d. Addr# -> Int# -> Word8X16# -> State# d -> State# d writeWord8OffAddrAsWord8X32# :: forall d. Addr# -> Int# -> Word8X32# -> State# d -> State# d writeWord8OffAddrAsWord8X64# :: forall d. Addr# -> Int# -> Word8X64# -> State# d -> State# d ===================================== testsuite/tests/primops/should_run/UnalignedAddrPrimOps.hs ===================================== @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Main where + +#include "MachDeps.h" + +import GHC.Ptr(Ptr(..), nullPtr, plusPtr, minusPtr) +import GHC.Stable( + StablePtr(..), castStablePtrToPtr, castPtrToStablePtr, newStablePtr) +import GHC.Exts +import Data.Char(ord) +import GHC.Int +import GHC.Word +import GHC.IO + +assertEqual :: (Show a, Eq a) => String -> a -> a -> IO () +assertEqual msg a b + | a /= b = putStrLn (msg ++ " " ++ show a ++ " /= " ++ show b) + | otherwise = return () + +readBytes :: MutableByteArray# s -> State# s -> Int# -> (# State# s, [Word8] #) +readBytes marr s0 len = go s0 len [] + where + go s 0# bs = (# s, bs #) + go s i bs = case readWord8Array# marr (i -# 1#) s of + (# s', b #) -> go s' (i -# 1#) (W8# b : bs) + +indexBytes :: Addr# -> Int# -> [Word8] +indexBytes arr len = + [W8# (indexWord8OffAddr# arr i) | I# i <- [0..I# len - 1]] + +test :: (Eq a, Show a) + => String + -> (Addr# -> Int# -> a) + -> (Addr# -> Int# -> State# RealWorld + -> (# State# RealWorld, a #)) + -> (Addr# -> Int# -> a -> State# RealWorld + -> State# RealWorld) + -> a + -> [Word8] + -> Int + -> IO () +test name index read write val valBytes len = do + putStrLn name + mapM_ testAtOffset [0..16] + where + arrLen :: Int# + arrLen = 24# + + fillerByte :: Word8 + fillerByte = 0x34 + + expectedArrayBytes :: Int -> [Word8] + expectedArrayBytes offset = + replicate offset fillerByte + ++ valBytes + ++ replicate (fromIntegral $ I# arrLen - len - offset) fillerByte + + testAtOffset :: Int -> IO () + testAtOffset offset@(I# offset#) = IO (\s0 -> let + !(# s1, marr #) = newPinnedByteArray# arrLen s0 + !s2 = setByteArray# marr 0# arrLen (case fromIntegral fillerByte of I# i# -> i#) s1 + !addr = mutableByteArrayContents# marr + in keepAlive# marr s2 (\s2 -> let + !s3 = write addr offset# val s2 + !(# s4, readOpResult #) = read addr offset# s3 + !(# s5, bytesAfterWrite #) = readBytes marr s4 arrLen + !(# s6, arr #) = unsafeFreezeByteArray# marr s5 + -- we want to tie the index operations to the State# token so that they happen after the mutations + !addrFrozen = byteArrayContents# arr + bytesViaAddrAfterWrite = indexBytes addrFrozen arrLen + indexOpResult = index addrFrozen offset# + in + unIO (do + assertEqual "readOpResult" readOpResult val + assertEqual "indexOpResult" indexOpResult val + assertEqual "bytesAfterWrite indexed" bytesAfterWrite (expectedArrayBytes offset) + assertEqual "bytesViaAddrAfterWrite indexed" bytesViaAddrAfterWrite (expectedArrayBytes offset)) s6 + ) + ) + +intToBytes :: Word64 -> Int -> [Word8] +intToBytes (W64# val0) (I# len0) = let + result = go val0 len0 + go v 0# = [] + go v len = + W8# (wordToWord8# (word64ToWord# v)) : go (v `uncheckedShiftRL64#` 8#) (len -# 1#) + in +#if defined(WORDS_BIGENDIAN) + reverse result +#else + result +#endif + +testIntArray :: (Eq a, Show a, Integral a, Num a) + => String + -> (Addr# -> Int# -> a) + -> (Addr# -> Int# -> State# RealWorld + -> (# State# RealWorld, a #)) + -> (Addr# -> Int# -> a -> State# RealWorld + -> State# RealWorld) + -> a + -> Int + -> IO () +testIntArray name0 index read write val0 len = do + doOne (name0 ++ " positive") val0 + doOne (name0 ++ " negative") (negate val0) + where + doOne name val = test name index read write + val (intToBytes (fromIntegral val) len) len + +testWordArray :: (Eq a, Show a, Integral a) + => String + -> (Addr# -> Int# -> a) + -> (Addr# -> Int# -> State# RealWorld + -> (# State# RealWorld, a #)) + -> (Addr# -> Int# -> a -> State# RealWorld + -> State# RealWorld) + -> a + -> Int + -> IO () +testWordArray name index read write val len = + test name index read write + val (intToBytes (fromIntegral val) len) len + +wordSizeInBytes :: Int +wordSizeInBytes = WORD_SIZE_IN_BITS `div` 8 + +int :: Int +int + | WORD_SIZE_IN_BITS == 32 = 12345678 + | otherwise = 1234567890123 + +word :: Word +word = fromIntegral int + +float :: Float +float = 123.456789 + +-- Test pattern generated by this python code: +-- >>> import struct +-- >>> import binascii +-- >>> binascii.hexlify(struct.pack('>f', 123.456789)) +floatBytes :: Word64 +floatBytes = 0x42f6e9e0 + +double :: Double +double = 123.45678901234 + +-- Test pattern generated by this python code: +-- >>> import struct +-- >>> import binascii +-- >>> binascii.hexlify(struct.pack('>d', 123.45678901234)) +doubleBytes :: Word64 +doubleBytes = 0x405edd3c07fb4b09 + +main :: IO () +main = do + testIntArray "Int8#" + (\arr i -> I8# (indexInt8OffAddr# arr i)) + (\arr i s -> case readInt8OffAddr# arr i s of (# s', a #) -> (# s', I8# a #)) + (\arr i (I8# a) s -> writeInt8OffAddr# arr i a s) + 123 1 + testIntArray "Int16#" + (\arr i -> I16# (indexWord8OffAddrAsInt16# arr i)) + (\arr i s -> case readWord8OffAddrAsInt16# arr i s of (# s', a #) -> (# s', I16# a #)) + (\arr i (I16# a) s -> writeWord8OffAddrAsInt16# arr i a s) + 12345 2 + testIntArray "Int32#" + (\arr i -> I32# (indexWord8OffAddrAsInt32# arr i)) + (\arr i s -> case readWord8OffAddrAsInt32# arr i s of (# s', a #) -> (# s', I32# a #)) + (\arr i (I32# a) s -> writeWord8OffAddrAsInt32# arr i a s) + 12345678 4 + testIntArray "Int64#" + (\arr i -> I64# (indexWord8OffAddrAsInt64# arr i)) + (\arr i s -> case readWord8OffAddrAsInt64# arr i s of (# s', a #) -> (# s', I64# a #)) + (\arr i (I64# a) s -> writeWord8OffAddrAsInt64# arr i a s) + 1234567890123 8 + testIntArray "Int#" + (\arr i -> I# (indexWord8OffAddrAsInt# arr i)) + (\arr i s -> case readWord8OffAddrAsInt# arr i s of (# s', a #) -> (# s', I# a #)) + (\arr i (I# a) s -> writeWord8OffAddrAsInt# arr i a s) + int wordSizeInBytes + + testWordArray "Word8#" + (\arr i -> W8# (indexWord8OffAddr# arr i)) + (\arr i s -> case readWord8OffAddr# arr i s of (# s', a #) -> (# s', W8# a #)) + (\arr i (W8# a) s -> writeWord8OffAddr# arr i a s) + 123 1 + testWordArray "Word16#" + (\arr i -> W16# (indexWord8OffAddrAsWord16# arr i)) + (\arr i s -> case readWord8OffAddrAsWord16# arr i s of (# s', a #) -> (# s', W16# a #)) + (\arr i (W16# a) s -> writeWord8OffAddrAsWord16# arr i a s) + 12345 2 + testWordArray "Word32#" + (\arr i -> W32# (indexWord8OffAddrAsWord32# arr i)) + (\arr i s -> case readWord8OffAddrAsWord32# arr i s of (# s', a #) -> (# s', W32# a #)) + (\arr i (W32# a) s -> writeWord8OffAddrAsWord32# arr i a s) + 12345678 4 + testWordArray "Word64#" + (\arr i -> W64# (indexWord8OffAddrAsWord64# arr i)) + (\arr i s -> case readWord8OffAddrAsWord64# arr i s of (# s', a #) -> (# s', W64# a #)) + (\arr i (W64# a) s -> writeWord8OffAddrAsWord64# arr i a s) + 1234567890123 8 + testWordArray "Word#" + (\arr i -> W# (indexWord8OffAddrAsWord# arr i)) + (\arr i s -> case readWord8OffAddrAsWord# arr i s of (# s', a #) -> (# s', W# a #)) + (\arr i (W# a) s -> writeWord8OffAddrAsWord# arr i a s) + word wordSizeInBytes + + test + "Char#" + (\arr i -> C# (indexWord8OffAddrAsChar# arr i)) + (\arr i s -> + case readWord8OffAddrAsChar# arr i s of (# s', a #) -> (# s', C# a #)) + (\arr i (C# a) s -> writeWord8OffAddrAsChar# arr i a s) + 'z' + [fromIntegral $ ord 'z'] + 1 + test + "WideChar#" + (\arr i -> C# (indexWord8OffAddrAsWideChar# arr i)) + (\arr i s -> + case readWord8OffAddrAsWideChar# arr i s of (# s', a #) -> (# s', C# a #)) + (\arr i (C# a) s -> writeWord8OffAddrAsWideChar# arr i a s) + '𠜎' -- See http://www.i18nguy.com/unicode/supplementary-test.html + (intToBytes (fromIntegral $ ord '𠜎') 4) + 4 + test + "Addr#" + (\arr i -> Ptr (indexWord8OffAddrAsAddr# arr i)) + (\arr i s -> + case readWord8OffAddrAsAddr# arr i s of (# s', a #) -> (# s', Ptr a #)) + (\arr i (Ptr a) s -> writeWord8OffAddrAsAddr# arr i a s) + (nullPtr `plusPtr` int) + (intToBytes (fromIntegral word) wordSizeInBytes) + wordSizeInBytes + + stablePtr <- newStablePtr () + test + "StablePtr#" + (\arr i -> + castStablePtrToPtr (StablePtr (indexWord8OffAddrAsStablePtr# arr i))) + (\arr i s -> case readWord8OffAddrAsStablePtr# arr i s of + (# s', a #) -> (# s', castStablePtrToPtr (StablePtr a) #)) + (\arr i p s -> case castPtrToStablePtr p of + (StablePtr a) -> writeWord8OffAddrAsStablePtr# arr i a s) + (castStablePtrToPtr stablePtr) + (intToBytes (fromIntegral $ castStablePtrToPtr stablePtr `minusPtr` nullPtr) + wordSizeInBytes) + wordSizeInBytes + + test + "Float#" + (\arr i -> F# (indexWord8OffAddrAsFloat# arr i)) + (\arr i s -> + case readWord8OffAddrAsFloat# arr i s of (# s', a #) -> (# s', F# a #)) + (\arr i (F# a) s -> writeWord8OffAddrAsFloat# arr i a s) + float + (intToBytes floatBytes 4) + 4 + test + "Double#" + (\arr i -> D# (indexWord8OffAddrAsDouble# arr i)) + (\arr i s -> + case readWord8OffAddrAsDouble# arr i s of (# s', a #) -> (# s', D# a #)) + (\arr i (D# a) s -> writeWord8OffAddrAsDouble# arr i a s) + double + (intToBytes doubleBytes 8) + 8 ===================================== testsuite/tests/primops/should_run/UnalignedAddrPrimOps.stdout ===================================== @@ -0,0 +1,21 @@ +Int8# positive +Int8# negative +Int16# positive +Int16# negative +Int32# positive +Int32# negative +Int64# positive +Int64# negative +Int# positive +Int# negative +Word8# +Word16# +Word32# +Word64# +Word# +Char# +WideChar# +Addr# +StablePtr# +Float# +Double# ===================================== testsuite/tests/primops/should_run/all.T ===================================== @@ -5,6 +5,7 @@ test('T4442', [when(wordsize(32), expect_broken(15184))], compile_and_run, ['']) test('T10481', exit_code(1), compile_and_run, ['']) +test('UnalignedAddrPrimOps', normal, compile_and_run, ['']) test('T10678', [ collect_stats('bytes allocated',5), only_ways(['normal']), ===================================== utils/genprimopcode/AccessOps.hs ===================================== @@ -171,7 +171,6 @@ mkIndexOffAddrOp e = PrimOpSpec , opts = [OptionEffect CanFail] } -{- mkUnalignedIndexOffAddrOp :: ElementType -> Entry mkUnalignedIndexOffAddrOp e = PrimOpSpec { cons = "IndexOffAddrOp_Word8As" ++ elt_name e @@ -183,7 +182,6 @@ mkUnalignedIndexOffAddrOp e = PrimOpSpec , desc = "Read " ++ elt_desc e ++ "; offset in bytes." , opts = [OptionEffect CanFail] } --} mkReadOffAddrOp :: ElementType -> Entry mkReadOffAddrOp e = PrimOpSpec @@ -198,7 +196,6 @@ mkReadOffAddrOp e = PrimOpSpec , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail] } -{- mkUnalignedReadOffAddrOp :: ElementType -> Entry mkUnalignedReadOffAddrOp e = PrimOpSpec { cons = "ReadOffAddrOp_Word8As" ++ elt_name e @@ -210,7 +207,6 @@ mkUnalignedReadOffAddrOp e = PrimOpSpec , desc = "Read " ++ elt_desc e ++ "; offset in bytes." , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail] } --} mkWriteOffAddrOp :: ElementType -> Entry mkWriteOffAddrOp e = PrimOpSpec @@ -225,7 +221,6 @@ mkWriteOffAddrOp e = PrimOpSpec , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail] } -{- mkUnalignedWriteOffAddrOp :: ElementType -> Entry mkUnalignedWriteOffAddrOp e = PrimOpSpec { cons = "WriteOffAddrOp_Word8As" ++ elt_name e @@ -237,14 +232,13 @@ mkUnalignedWriteOffAddrOp e = PrimOpSpec , desc = "Write " ++ elt_desc e ++ "; offset in bytes." , opts = [OptionEffect ReadWriteEffect, OptionCanFailWarnFlag YesWarnCanFail] } --} addrAccessOps :: [Entry] addrAccessOps = map mkIndexOffAddrOp elementTypes --- ++ map mkUnalignedIndexOffAddrOp unalignedElementTypes + ++ map mkUnalignedIndexOffAddrOp unalignedElementTypes ++ map mkReadOffAddrOp elementTypes --- ++ map mkUnalignedReadOffAddrOp unalignedElementTypes + ++ map mkUnalignedReadOffAddrOp unalignedElementTypes ++ map mkWriteOffAddrOp elementTypes --- ++ map mkUnalignedWriteOffAddrOp unalignedElementTypes + ++ map mkUnalignedWriteOffAddrOp unalignedElementTypes View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eaf72479eacaa092e87accd6780ea9c048f1dfcb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eaf72479eacaa092e87accd6780ea9c048f1dfcb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 04:04:34 2024 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 06 Jan 2024 23:04:34 -0500 Subject: [Git][ghc/ghc][master] Remove VoidRep from PrimRep, introduce PrimOrVoidRep Message-ID: <659a22d2a847e_95277b292c9078257@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d471d445 by Krzysztof Gogolewski at 2024-01-06T23:03:47-05:00 Remove VoidRep from PrimRep, introduce PrimOrVoidRep This introduces data PrimOrVoidRep = VoidRep | NVRep PrimRep changes typePrimRep1 to return PrimOrVoidRep, and adds a new function typePrimRepU to be used when the argument is definitely non-void. Details in Note [VoidRep] in GHC.Types.RepType. Fixes #19520 - - - - - 25 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/InfoTable.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/HsToCore/Foreign/Utils.hs - compiler/GHC/Stg/Lift/Analysis.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Stg/Syntax.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm.hs - compiler/GHC/StgToCmm/ArgRep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Closure.hs - compiler/GHC/StgToCmm/Env.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Lit.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToJS/Arg.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Types.Demand import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) @@ -857,7 +857,8 @@ primOpSig op GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep + = ReturnsVoid + | ReturnsPrim PrimRep | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value @@ -867,8 +868,11 @@ data PrimOpResultInfo getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) | isUnboxedTupleTyCon tc -> ReturnsTuple | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where ===================================== compiler/GHC/ByteCode/InfoTable.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -61,7 +61,7 @@ make_constr_itbls interp profile cons = where mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + let rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Cmm.Utils( import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -97,7 +97,6 @@ import GHC.Cmm.Dataflow.Collections primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +135,10 @@ primElemRepCmmType Word64ElemRep = b64 primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +155,8 @@ primRepForeignHint FloatRep = NoHint primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -126,8 +126,9 @@ module GHC.Core.TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, + isGcPtrRep, primRepSizeB, primRepSizeW64_B, primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, @@ -1532,17 +1533,18 @@ See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. -} --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, +-- | A 'PrimRep' is an abstraction of a /non-void/ type. +-- (Use 'PrimRepOrVoidRep' if you want void types too.) +-- It contains information that the code generator needs +-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep -- Unpacking of sum types is only supported since 9.6.1 #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value #else - | BoxedRep !(Maybe Levity) -- ^ Boxed, heap value + = BoxedRep !(Maybe Levity) -- ^ Boxed, heap value #endif | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -1560,6 +1562,9 @@ data PrimRep | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1580,58 +1585,52 @@ instance Outputable PrimElemRep where ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1676,7 +1675,6 @@ primRepSizeB platform = \case DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep -- | Like primRepSizeB but assumes pointers/words are 8 words wide. @@ -1699,7 +1697,6 @@ primRepSizeW64_B = \case DoubleRep -> dOUBLE_SIZE AddrRep -> 8 BoxedRep{} -> 8 - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeW64_B rep primElemRepSizeB :: Platform -> PrimElemRep -> Int ===================================== compiler/GHC/HsToCore/Foreign/Utils.hs ===================================== @@ -57,7 +57,7 @@ primTyDescChar :: Platform -> Type -> Char primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' ===================================== compiler/GHC/Stg/Lift/Analysis.hs ===================================== @@ -418,7 +418,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -377,16 +377,10 @@ lintStgAppReps fun args = do match_args (Nothing:_) _ = return () match_args (_) (Nothing:_) = return () match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left) - -- Common case, reps are exactly the same + -- Common case, reps are exactly the same (perhaps void) | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep (empty list) - -- Note typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. - | isVoidRep actual_rep && isVoidRep expected_rep - = match_args actual_reps_left expected_reps_left - -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep. -- We check for that here with primRepCompatible | primRepsCompatible platform actual_rep expected_rep @@ -409,8 +403,6 @@ lintStgAppReps fun args = do -- text "expected reps:" <> ppr arg_ty_reps $$ text "unarised?:" <> ppr (lf_unarised lf)) where - isVoidRep [] = True - isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which -- will result in a lint failure in match_args. ===================================== compiler/GHC/Stg/Syntax.hs ===================================== @@ -58,6 +58,7 @@ module GHC.Stg.Syntax ( stgArgType, stgArgRep, stgArgRep1, + stgArgRepU, stgArgRep_maybe, stgCaseBndrInScope, @@ -80,7 +81,7 @@ import GHC.Types.CostCentre ( CostCentreStack ) import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -90,7 +91,7 @@ import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep, typePrimRep_maybe ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable @@ -177,10 +178,10 @@ isDllConApp platform ext_dyn_refs this_mod con args -- $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep -isAddrRep :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False +isAddrRep :: PrimOrVoidRep -> Bool +isAddrRep (NVRep AddrRep) = True +isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript +isAddrRep _ = False -- | Type of an @StgArg@ -- @@ -199,11 +200,17 @@ stgArgRep ty = typePrimRep (stgArgType ty) stgArgRep_maybe :: StgArg -> Maybe [PrimRep] stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) --- | Assumes that the argument has one PrimRep, which holds after unarisation. +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -stgArgRep1 :: StgArg -> PrimRep +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep stgArgRep1 ty = typePrimRep1 (stgArgType ty) +-- | Assumes that the argument has exactly one PrimRep. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -373,6 +373,7 @@ STG programs after unarisation have these invariants: 2. No unboxed tuple binders. Tuples only appear in return position. 3. Binders and literals always have zero (for void arguments) or one PrimRep. + (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.) 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments. This means that it's safe to wrap `StgArg`s of DataCon applications with @@ -607,13 +608,12 @@ unariseUbxSumOrTupleArgs rho us dc args ty_args -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -814,7 +814,7 @@ mapSumIdBinders alt_bndr args rhs rho0 mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) mkCastInput (id,rep,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) rep + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -860,7 +860,7 @@ mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -922,8 +922,8 @@ mkUbxSum dc ty_args args0 us castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= stgArgRep1 arg - , (ops,types) <- unzip $ getCasts (stgArgRep1 arg) $ slotPrimRep slot_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -57,7 +57,7 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRep, +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, nonVoidIds, nonVoidStgArgs ) import GHC.StgToCmm.Layout @@ -529,7 +529,7 @@ returnUnboxedTuple returnUnboxedTuple d s p es = do profile <- getProfile let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (stgArgRep1 e) + arg_ty e = primRepCmmType platform (stgArgRepU e) (call_info, tuple_components) = layoutNativeCall profile NativeTupleReturn d @@ -540,12 +540,14 @@ returnUnboxedTuple d s p es = do massert (off == dd + szb) go (dd + szb) (push:pushes) cs pushes <- go d [] tuple_components - let non_void VoidRep = False - non_void _ = True + let rep_to_maybe :: PrimOrVoidRep -> Maybe PrimRep + rep_to_maybe VoidRep = Nothing + rep_to_maybe (NVRep rep) = Just rep + ret <- returnUnliftedReps d s (wordsToBytes platform $ nativeCallSize call_info) - (filter non_void $ map stgArgRep1 es) + (mapMaybe (rep_to_maybe . stgArgRep1) es) return (mconcat pushes `appOL` ret) -- Compile code to apply the given expression to the remaining args @@ -928,7 +930,7 @@ doCase d s p scrut bndr alts rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . idPrimRep + let bndr_ty = primRepCmmType platform . idPrimRepU tuple_start = d_bndr (call_info, args_offsets) = layoutNativeCall profile @@ -944,7 +946,7 @@ doCase d s p scrut bndr alts wordsToBytes platform (nativeCallSize call_info) + offset) | (arg, offset) <- args_offsets - , not (isVoidRep $ idPrimRep arg)] + , not (isZeroBitTy $ idType arg)] p_alts in do rhs_code <- schemeE stack_bot s p' rhs @@ -1378,10 +1380,10 @@ generatePrimCall d s p target _mb_unit _result_ty args layoutNativeCall profile NativePrimCall 0 - (primRepCmmType platform . stgArgRep1) + (primRepCmmType platform . stgArgRepU) nv_args - prim_args_offsets = mapFst stgArgRep1 args_offsets + prim_args_offsets = mapFst stgArgRepU args_offsets shifted_args_offsets = mapSnd (+ d) args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 @@ -1457,7 +1459,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- ArgRep of what was actually pushed. pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] pargs _ [] = return [] pargs d (aa@(StgVarArg a):az) | Just t <- tyConAppTyCon_maybe (idType a) @@ -1470,7 +1472,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) + return ((code, NVRep AddrRep) : rest) pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa rest <- pargs (d + sz_a) az return ((code_a, stgArgRep1 aa) : rest) @@ -1483,8 +1485,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x + | VoidRep:xs <- a_reps_pushed_r_to_l = reverse xs | otherwise = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" @@ -1494,10 +1495,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- d_after_args is the stack depth once the args are on. -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) + r_rep = maybe_getCCallReturnRep result_ty {- Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call @@ -1570,10 +1568,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- this is a V (tag). r_sizeW = repSizeWords platform r_rep d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) -- generate the marshalling code we're going to call @@ -1611,17 +1608,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) result_ty args -- slide and return d_after_r_min_s = bytesToWords platform (d_after_r - s) wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) + `snocOL` RETURN (toArgRepOrV platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup ) -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) = case r of - VoidRep -> FFIVoid IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> FFISInt8 @@ -1668,7 +1665,7 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- --- to Just IntRep +-- to NVRep IntRep -- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert @@ -1676,16 +1673,16 @@ mkDummyLiteral platform pr -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) -- --- to Nothing +-- to VoidRep -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) in case typePrimRep r_ty of - [] -> Nothing - [rep] -> Just rep + [] -> VoidRep + [rep] -> NVRep rep -- if it was, it would be impossible to create a -- valid return value placeholder on the stack @@ -2131,10 +2128,10 @@ idSizeCon platform var wordsToBytes platform . WordOff . sum . map (argRepSizeW platform . toArgRep platform) . typePrimRep . idType $ var - | otherwise = ByteOff (primRepSizeB platform (idPrimRep var)) + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) isFollowableArg :: ArgRep -> Bool isFollowableArg P = True @@ -2171,7 +2168,7 @@ mkSlideW !n !ws atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (stgArgRep1 e) +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which -- has initial depth @original_depth at . Return the values which the stack ===================================== compiler/GHC/StgToCmm.hs ===================================== @@ -253,8 +253,8 @@ cgDataCon mn data_con -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) ] ===================================== compiler/GHC/StgToCmm/ArgRep.hs ===================================== @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ module GHC.StgToCmm.ArgRep ( import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -68,7 +68,6 @@ argRepString V64 = "V64" toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ toArgRep platform rep = case rep of 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ argRepSizeW platform = \case ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -382,7 +382,7 @@ mkRhsClosure profile use_std_ap check_tags bndr _cc -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) ===================================== compiler/GHC/StgToCmm/Closure.hs ===================================== @@ -18,7 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -176,24 +176,27 @@ assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) + +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) -- | Assumes that Ids have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. -- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (stgArgRep1 arg', arg')) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo ===================================== compiler/GHC/StgToCmm/Env.hs ===================================== @@ -205,4 +205,4 @@ idToReg :: Platform -> NonVoid Id -> LocalReg -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -488,7 +488,7 @@ accurate update would complexify the implementation and doesn't seem worth it. -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -522,9 +522,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/StgToCmm/Layout.hs ===================================== @@ -26,7 +26,7 @@ module GHC.StgToCmm.Layout ( mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +50,7 @@ import GHC.Cmm.Info import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -330,8 +330,8 @@ getArgRepsAmodes args = do where getArgRepAmode platform arg = case stgArgRep1 arg of VoidRep -> return (V, Nothing) - rep -> do expr <- getArgAmode (NonVoid arg) - return (toArgRep platform rep, Just expr) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -438,7 +438,6 @@ mkVirtHeapOffsetsWithPadding -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -520,13 +519,13 @@ mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- ===================================== compiler/GHC/StgToCmm/Lit.hs ===================================== @@ -52,7 +52,6 @@ cgLit (LitString s) = -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1812,7 +1812,7 @@ emitPrimOp cfg primop = -> PrimopCmmEmit opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do regs <- case result_info of - ReturnsPrim VoidRep -> pure [] + ReturnsVoid -> pure [] ReturnsPrim rep -> do reg <- newTemp (primRepCmmType platform rep) pure [reg] ===================================== compiler/GHC/StgToCmm/Ticky.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -615,7 +615,7 @@ tickySlowCall lf_info args = do tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform . stgArgRep1) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps ===================================== compiler/GHC/StgToJS/Arg.hs ===================================== @@ -120,7 +120,7 @@ genStaticArg a = case a of Nothing -> reg Just expr -> unfloated expr where - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -162,7 +162,7 @@ genArg a = case a of where -- if our argument is a joinid, it can be an unboxed tuple r :: HasDebugCallStack => JSRep - r = primRepToJSRep $ stgArgRep1 a + r = primOrVoidRepToJSRep $ stgArgRep1 a unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -351,7 +351,7 @@ genBody ctx startReg args e typ = do -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -20,6 +20,7 @@ module GHC.StgToJS.Utils , typeJSRep , unaryTypeJSRep , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType , primRepSize , mkArityTag @@ -196,10 +197,9 @@ typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep -unaryTypeJSRep ut = primRepToJSRep (typePrimRep1 ut) +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep -primRepToJSRep VoidRep = VoidV primRepToJSRep (BoxedRep _) = PtrV primRepToJSRep IntRep = IntV primRepToJSRep Int8Rep = IntV @@ -216,6 +216,10 @@ primRepToJSRep FloatRep = DoubleV primRepToJSRep DoubleRep = DoubleV primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -1525,7 +1525,6 @@ shouldUnpackArgTy bang_opts prag fam_envs arg_ty -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] is_small_rep = let -- Neccesary to look through unboxed tuples. - -- Note typePrimRep never returns VoidRep prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys -- And then get the actual size of the unpacked constructor. rep_size = sum $ map primRepSizeW64_B prim_reps ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -11,11 +11,11 @@ module GHC.Types.RepType isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type @@ -38,7 +38,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -80,15 +80,6 @@ isNvUnaryRep :: [PrimRep] -> Bool isNvUnaryRep [_] = True isNvUnaryRep _ = False --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty - -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: -- 1. Casts @@ -129,7 +120,10 @@ countFunRepArgs 0 _ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = (length (typePrimRep arg) `max` 1) + + countFunRepArgs (n - 1) res + -- If typePrimRep returns [] that means a void arg, + -- and we count 1 for that | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -308,7 +302,6 @@ repSlotTy reps = case reps of _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -391,8 +384,7 @@ needed and how many bits are required. The data type GHC.Core.TyCon.PrimRep enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -441,18 +433,37 @@ See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]. Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) + +For example: + typePrimRep Int# = [IntRep] + typePrimRep Int = [LiftedRep] + typePrimRep (# Int#, Int# #) = [IntRep,IntRep] + typePrimRep (# #) = [] + typePrimRep (State# s) = [] + +After the unariser, all identifiers have at most one PrimRep +(that is, the [PrimRep] for each identifier is empty or a singleton list). +More precisely: typePrimRep1 will succeed (not crash) on every binder +and argument type. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +Thus, we have -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +1. typePrimRep :: Type -> [PrimRep] + which returns the list + +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. typePrimRep1 :: Type -> PrimOrVoidRep + data PrimOrVoidRep = VoidRep | NVRep PrimRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1, +which have analogous preconditions. Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -546,17 +557,22 @@ typePrimRep ty = kindPrimRep (text "typePrimRep" <+> typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -567,15 +583,6 @@ tyConPrimRep tc where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -603,8 +610,6 @@ kindPrimRep_maybe ki -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -617,8 +622,7 @@ runtimeRepPrimRep doc rr_ty -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -634,7 +638,6 @@ runtimeRepPrimRep_maybe rr_ty -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d471d4459587dcd154738c50bf4eeb1f89ce46c2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d471d4459587dcd154738c50bf4eeb1f89ce46c2 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 13:37:47 2024 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Sun, 07 Jan 2024 08:37:47 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] More Message-ID: <659aa92bb4f58_1dbc904f195d847791@gitlab.mail> Simon Peyton Jones pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 5b48e79c by Simon Peyton Jones at 2024-01-07T13:35:13+00:00 More - - - - - 12 changed files: - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Utils/Unify.hs - testsuite/tests/typecheck/should_fail/FD1.stderr - testsuite/tests/typecheck/should_fail/T10709b.stderr - testsuite/tests/typecheck/should_fail/T12947.stderr - testsuite/tests/typecheck/should_fail/tcfail175.stderr Changes: ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -1040,7 +1040,7 @@ data TcRnMessage where Test cases: typecheck/should_compile/T11339 -} - TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage + TcRnOverloadedSig :: TcIdSig -> TcRnMessage {-| TcRnTupleConstraintInst is an error that occurs whenever an instance for a tuple constraint is specified. ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -824,7 +824,6 @@ checkMonomorphismRestriction mbis lbinds no_mr_name (MBI { mbi_sig = Just sig }) | TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig = case info of - TcPatSynSig {} -> Nothing -- Never happens TcCompleteSig (CSig { sig_bndr = bndr }) -> Just (idName bndr) TcPartialSig (PSig { psig_name = nm }) | null theta, isNothing wcx -> Nothing -- f :: _ -> _ @@ -1541,7 +1540,7 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name , fun_matches = matches }) - | Just sig <- sig_fn name + | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature. -- It must be partial; if complete we'd be in tcPolyCheck! -- e.g. f :: _ -> _ @@ -1591,10 +1590,10 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a bndr_names = collectPatBinders CollNoDictBinders pat (nosig_names, sig_names) = partitionWith find_sig bndr_names - find_sig :: Name -> Either Name (Name, TcIdSigInfo) + find_sig :: Name -> Either Name (Name, TcIdSig) find_sig name = case sig_fn name of - Just sig -> Right (name, sig) - _ -> Left name + Just (TcIdSig sig) -> Right (name, sig) + _ -> Left name tcLhs _ _ b@(PatSynBind {}) = pprPanic "tcLhs: PatSynBind" (ppr b) -- pattern synonyms are handled separately; see tc_single @@ -1613,7 +1612,7 @@ lookupMBI name , mbi_mono_mult = idMult mono_id }) } ------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo +tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo tcLhsSigId no_gen (name, sig) = do { inst_sig <- tcInstSig sig ; mono_id <- newSigLetBndr no_gen name inst_sig @@ -1878,7 +1877,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds -- except a single function binding with a complete signature one_funbind_with_sig | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcCompleteSig sig) <- sig_fn (unLoc v) + , Just (TcIdSig (TcCompleteSig sig)) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise = Nothing @@ -1886,8 +1885,8 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds binders = collectHsBindListBinders CollNoDictBinders lbinds has_partial_sigs = any has_partial_sig binders has_partial_sig nm = case sig_fn nm of - Just (TcPartialSig {}) -> True - _ -> False + Just (TcIdSig (TcPartialSig {})) -> True + _ -> False has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsNoMultAnn{}})) = False has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -113,12 +113,13 @@ tcCheckPolyExpr, tcCheckPolyExprNC tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) +----------------- -- These versions take an ExpType tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -128,14 +129,20 @@ tcPolyLExprNC (L loc expr) res_ty do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } - +----------------- tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcPolyExpr e (Infer inf) = tcExpr e (Infer inf) tcPolyExpr e (Check ty) = tcPolyExprCheck e (Left ty) +----------------- tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) tcPolyLExprSig (L loc expr) sig - = setSrcSpanA loc $ addExprCtxt expr $ + = setSrcSpanA loc $ + -- No addExprCtxt. For (e :: ty) we don't want generate + -- In the expression e + -- In the expression e :: ty + -- We have already got an error-context for (e::ty), so when we + -- get to `e`, just add the location do { expr' <- tcPolyExprCheck expr (Right sig) ; return (L loc expr') } ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -978,8 +978,7 @@ tcExprWithSig expr hs_ty where loc = getLocA (dropWildCards hs_ty) -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) -tcExprSig _ (TcPatSynSig sig) = pprPanic "tcExprSig" (ppr sig) +tcExprSig :: LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType) tcExprSig expr (TcCompleteSig sig) = do { expr' <- tcPolyLExprSig expr sig ; return (expr', idType (sig_bndr sig)) } ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} module GHC.Tc.Gen.Sig( - TcSigInfo(..), TcIdSigInfo, TcSigFun, + TcSigInfo(..), TcIdSig(..), TcSigFun, isPartialSig, hasCompleteSig, tcSigInfoName, tcSigInfoLoc, completeSigPolyId_maybe, isCompleteHsSig, @@ -171,21 +171,24 @@ tcTySig (L _ (XSig (IdSig id))) -- NoRRC: do not report redundant constraints -- The user has no control over the signature! sig = completeSigFromId ctxt id - ; return [TcCompleteSig sig] } + ; return [TcIdSig (TcCompleteSig sig)] } tcTySig (L loc (TypeSig _ names sig_ty)) = setSrcSpanA loc $ - sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) | L _ name <- names ] + do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } tcTySig (L loc (PatSynSig _ names sig_ty)) = setSrcSpanA loc $ - sequence [ tcPatSynSig name sig_ty | L _ name <- names ] + do { tpsigs <- sequence [ tcPatSynSig name sig_ty + | L _ name <- names ] + ; return (map TcPatSynSig tpsigs) } tcTySig _ = return [] -tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo -- Never returns PatSynSig +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSig -- A function or expression type signature -- Returns a fully quantified type signature; even the wildcards -- are quantified with ordinary skolems that should be instantiated @@ -372,7 +375,7 @@ later. Pattern synonyms are top-level, so there's no problem with completely solving them. -} -tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcSigInfo +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynSig -- See Note [Pattern synonym signatures] -- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty})) @@ -447,7 +450,7 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs) , text "prov" <+> ppr prov , text "body_ty" <+> ppr body_ty ] - ; return $ TcPatSynSig $ + ; return $ PatSig { patsig_name = name , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs , patsig_univ_bndrs = univ_bndrs @@ -486,7 +489,7 @@ ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) ********************************************************************* -} -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst +tcInstSig :: TcIdSig -> TcM TcIdSigInst -- Instantiate a type signature; only used with plan InferGen tcInstSig hs_sig@(TcCompleteSig (CSig { sig_bndr = poly_id, sig_loc = loc })) = setSrcSpan loc $ -- Set the binding site of the tyvars @@ -517,9 +520,6 @@ tcInstSig hs_sig@(TcPartialSig (PSig { psig_hs_ty = hs_ty ; traceTc "End partial sig }" (ppr inst_sig) ; return inst_sig } -tcInstSig hs_sig@(TcPatSynSig {}) - = pprPanic "tcInstSig" (ppr hs_sig) - {- Note [Pattern bindings and complete signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -68,7 +68,7 @@ module GHC.Tc.Types( -- TcSigInfo TcSigFun, - TcSigInfo(..), TcIdSigInfo, + TcSigInfo(..), TcIdSig(..), TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..), TcIdSigInst(..), isPartialSig, hasCompleteSig, tcSigInfoName, tcSigInfoLoc, ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -5,10 +5,8 @@ module GHC.Tc.Types.BasicTypes ( , TcBinder(..) -- * Signatures - , TcSigFun, TcSigInfo(..), TcIdSigInfo - , TcCompleteSig(..) - , TcPartialSig(..) - , TcPatSynSig(..) + , TcSigFun, TcSigInfo(..), TcIdSig(..) + , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..) , TcIdSigInst(..) , isPartialSig, hasCompleteSig , tcSigInfoName, tcSigInfoLoc, completeSigPolyId_maybe @@ -46,7 +44,6 @@ import GHC.Tc.Errors.Types.PromotionErr (PromotionErr, peCategory) import GHC.Core.TyCon ( TyCon, tyConKind ) import GHC.Utils.Outputable import GHC.Utils.Misc -import GHC.Utils.Panic --------------------------- @@ -102,12 +99,14 @@ instance HasOccName TcBinder where type TcSigFun = Name -> Maybe TcSigInfo --- See Note [Complete and partial type signatures] -data TcSigInfo = TcCompleteSig TcCompleteSig -- For an Id - | TcPartialSig TcPartialSig -- For an Id - | TcPatSynSig TcPatSynSig -- For a pattern synonym +-- TcSigInfo is simply the domain of TcSigFun +data TcSigInfo = TcPatSynSig TcPatSynSig -- For a pattern synonym + | TcIdSig TcIdSig -type TcIdSigInfo = TcSigInfo -- Always TcIdCompleteSig or TcIdPartialSig +-- See Note [Complete and partial type signatures] +data TcIdSig -- For an Id + = TcCompleteSig TcCompleteSig + | TcPartialSig TcPartialSig data TcCompleteSig -- A complete signature with no wildcards, -- so the complete polymorphic type is known. @@ -162,7 +161,7 @@ sig_extra_cts is Nothing. -} data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo + = TISI { sig_inst_sig :: TcIdSig , sig_inst_skols :: [(Name, InvisTVBinder)] -- Instantiated type and kind variables, TyVarTvs @@ -248,9 +247,12 @@ Here we get -} instance Outputable TcSigInfo where + ppr (TcIdSig sig) = ppr sig + ppr (TcPatSynSig sig) = ppr sig + +instance Outputable TcIdSig where ppr (TcCompleteSig sig) = ppr sig ppr (TcPartialSig sig) = ppr sig - ppr (TcPatSynSig sig) = ppr sig instance Outputable TcCompleteSig where ppr (CSig { sig_bndr = bndr }) @@ -276,23 +278,22 @@ isPartialSig _ = False hasCompleteSig :: TcSigFun -> Name -> Bool hasCompleteSig sig_fn name = case sig_fn name of - Just (TcCompleteSig {}) -> True - _ -> False + Just (TcIdSig (TcCompleteSig {})) -> True + _ -> False tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcCompleteSig sig) = idName (sig_bndr sig) -tcSigInfoName (TcPartialSig sig) = psig_name sig -tcSigInfoName (TcPatSynSig sig) = patsig_name sig +tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig) +tcSigInfoName (TcIdSig (TcPartialSig sig)) = psig_name sig +tcSigInfoName (TcPatSynSig sig) = patsig_name sig -tcSigInfoLoc :: TcIdSigInfo -> SrcSpan +tcSigInfoLoc :: TcIdSig -> SrcSpan -- Only works for Id signatures, not PatSyn sigs tcSigInfoLoc (TcCompleteSig sig) = sig_loc sig tcSigInfoLoc (TcPartialSig sig) = psig_loc sig -tcSigInfoLoc (TcPatSynSig sig) = pprPanic "tcSigInfoLoc" (ppr sig) completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe (TcCompleteSig sig) = Just (sig_bndr sig) -completeSigPolyId_maybe _ = Nothing +completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig) +completeSigPolyId_maybe _ = Nothing {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -1471,8 +1471,13 @@ tcDeepSplitSigmaTyBndr_maybe = tcDeepSplit_maybe tcSplitSigmaTyBndrs * * ********************************************************************* -} -{- Note [Skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Skolemisation overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f :: (forall a. a->a) -> blah, and we have the application (f e) +Then we want to typecheck `e` pushing in the type `forall a. a->a`. So +in general, +* In (tcPolyExpr e poly_ty), we + tcTopSkolemise takes "expected type" and strip off quantifiers to expose the type underneath, binding the new skolems for the 'thing_inside' The returned 'HsWrapper' has type (specific_ty -> expected_ty). ===================================== testsuite/tests/typecheck/should_fail/FD1.stderr ===================================== @@ -7,4 +7,3 @@ FD1.hs:16:1: error: [GHC-25897] at FD1.hs:15:1-38 • The equation for ‘plus’ has two value arguments, but its type ‘Int -> a’ has only one - • Relevant bindings include plus :: Int -> a (bound at FD1.hs:16:1) ===================================== testsuite/tests/typecheck/should_fail/T10709b.stderr ===================================== @@ -1,9 +1,9 @@ T10709b.hs:6:22: error: [GHC-91028] - • Couldn't match type ‘p1’ with ‘forall a. IO a -> IO a’ - Expected: (p1 -> IO ()) -> IO () + • Couldn't match type ‘t2’ with ‘forall a. IO a -> IO a’ + Expected: (t2 -> IO ()) -> IO () Actual: ((forall a. IO a -> IO a) -> IO ()) -> IO () - Cannot instantiate unification variable ‘p1’ + Cannot instantiate unification variable ‘t2’ with a type involving polytypes: forall a. IO a -> IO a • In the second argument of ‘(.)’, namely ‘mask’ In the expression: (replicateM 2 . mask) (\ _ -> return ()) @@ -11,10 +11,10 @@ T10709b.hs:6:22: error: [GHC-91028] x4 = (replicateM 2 . mask) (\ _ -> return ()) T10709b.hs:7:22: error: [GHC-91028] - • Couldn't match type ‘t0’ with ‘forall a1. IO a1 -> IO a1’ - Expected: (t0 -> IO a) -> IO a + • Couldn't match type ‘t1’ with ‘forall a1. IO a1 -> IO a1’ + Expected: (t1 -> IO a) -> IO a Actual: ((forall a1. IO a1 -> IO a1) -> IO a) -> IO a - Cannot instantiate unification variable ‘t0’ + Cannot instantiate unification variable ‘t1’ with a type involving polytypes: forall a1. IO a1 -> IO a1 • In the second argument of ‘(.)’, namely ‘mask’ In the expression: (replicateM 2 . mask) (\ x -> undefined x) @@ -22,10 +22,10 @@ T10709b.hs:7:22: error: [GHC-91028] x5 = (replicateM 2 . mask) (\ x -> undefined x) T10709b.hs:8:22: error: [GHC-91028] - • Couldn't match type ‘p0’ with ‘forall a1. IO a1 -> IO a1’ - Expected: (p0 -> IO a) -> IO a + • Couldn't match type ‘t0’ with ‘forall a1. IO a1 -> IO a1’ + Expected: (t0 -> IO a) -> IO a Actual: ((forall a1. IO a1 -> IO a1) -> IO a) -> IO a - Cannot instantiate unification variable ‘p0’ + Cannot instantiate unification variable ‘t0’ with a type involving polytypes: forall a1. IO a1 -> IO a1 • In the second argument of ‘(.)’, namely ‘mask’ In the expression: (replicateM 2 . mask) (id (\ _ -> undefined)) ===================================== testsuite/tests/typecheck/should_fail/T12947.stderr ===================================== @@ -1,3 +1,3 @@ T12947.hs:15:14: error: [GHC-88464] - Data constructor not in scope: ContT :: (p0 -> m0 a0) -> P m a + Data constructor not in scope: ContT :: (t0 -> m0 a0) -> P m a ===================================== testsuite/tests/typecheck/should_fail/tcfail175.stderr ===================================== @@ -8,5 +8,3 @@ tcfail175.hs:11:1: error: [GHC-25897] at tcfail175.hs:10:1-19 • The equation for ‘evalRHS’ has three value arguments, but its type ‘Int -> a’ has only one - • Relevant bindings include - evalRHS :: Int -> a (bound at tcfail175.hs:11:1) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b48e79c91724b01207f5fad21c481e653eb481f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b48e79c91724b01207f5fad21c481e653eb481f You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 14:19:19 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Sun, 07 Jan 2024 09:19:19 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-metadata-fail] gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Message-ID: <659ab2e759f06_1dbc906216320505e4@gitlab.mail> Zubin pushed to branch wip/9.6.4-metadata-fail at Glasgow Haskell Compiler / GHC Commits: f60d485c by Zubin Duggal at 2024-01-07T19:48:43+05:30 gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Nix can't find ghc 9.2.4 for some reason, resulting in the lint-ci-config job failing Metric Decrease: MultiLayerModulesTH_Make Metric Increase: MultiLayerModulesTH_Make - - - - - 1 changed file: - .gitlab/generate_job_metadata Changes: ===================================== .gitlab/generate_job_metadata ===================================== @@ -1,5 +1,5 @@ #! /usr/bin/env nix-shell -#!nix-shell -i bash -p cabal-install "haskell.packages.ghc924.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq +#!nix-shell -i bash -p cabal-install "haskell.packages.ghc928.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq cd "$(dirname "${BASH_SOURCE[0]}")" cabal run gen_ci -- metadata jobs-metadata.json View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f60d485c4ea9b58e65c54a552e5f6dda06270293 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f60d485c4ea9b58e65c54a552e5f6dda06270293 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 14:37:35 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 07 Jan 2024 09:37:35 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/abs-den Message-ID: <659ab72f8fde6_1dbc906aa45b4510dc@gitlab.mail> Sebastian Graf pushed new branch wip/abs-den at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/abs-den You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 14:44:26 2024 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 07 Jan 2024 09:44:26 -0500 Subject: [Git][ghc/ghc][wip/abs-den] Write a denotationaler interpreter for Core Message-ID: <659ab8caea649_1dbc906d33b18512db@gitlab.mail> Sebastian Graf pushed to branch wip/abs-den at Glasgow Haskell Compiler / GHC Commits: b9d54222 by Sebastian Graf at 2024-01-07T15:44:17+01:00 Write a denotationaler interpreter for Core - - - - - 4 changed files: - compiler/GHC/Builtin/Uniques.hs - + compiler/GHC/Core/Semantics.hs - compiler/ghc.cabal.in - + ghdi.hs Changes: ===================================== compiler/GHC/Builtin/Uniques.hs ===================================== @@ -51,6 +51,9 @@ module GHC.Builtin.Uniques -- Boxing data types , mkBoxingTyConUnique, boxingDataConUnique + -- Denotational interpreter 'GHC.Core.Semantics.eval' + , mkTempDataConArgUnique + ) where import GHC.Prelude @@ -326,7 +329,8 @@ Allocation of unique supply characters: j constraint tuple superclass selectors k constraint tuple tycons m constraint tuple datacons - n Native/LLVM codegen + n Native/LLVM codegen, as well as GHC.Core.Semantics / demand analysis + (NB: The lifetimes of those uniques do not overlap) r Hsc name cache s simplifier u Cmm pipeline @@ -445,3 +449,8 @@ mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i) boxingDataConUnique :: Unique -> Unique boxingDataConUnique u = stepUnique u 2 + +-- | Make a temporary unique for a DataCon worker PAP, where we know exactly the +-- scope of said unique. Used in 'GHC.Core.Semantics.eval'. +mkTempDataConArgUnique :: Int -> Unique +mkTempDataConArgUnique i = mkUniqueInt 'n' i ===================================== compiler/GHC/Core/Semantics.hs ===================================== @@ -0,0 +1,247 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- {-# OPTIONS_GHC -fdefer-type-errors #-} +-- {-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Core.Semantics where + +import GHC.Prelude + +import GHC.Builtin.Names +import GHC.Builtin.Uniques + +import GHC.Core +import GHC.Core.Coercion +import GHC.Core.DataCon + +import qualified GHC.Data.Word64Map as WM + +import GHC.Types.Literal +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + +import GHC.Utils.Misc +import GHC.Utils.Outputable + +import Control.Monad +import Control.Monad.Trans.State +import Data.Word +import GHC.Core.Utils hiding (findAlt) +import GHC.Core.Type +import GHC.Builtin.PrimOps + +data Event = Lookup Name | LookupArg CoreExpr | Update | App1 | App2 | Case1 | Case2 | Let1 + +class Trace d where + step :: Event -> d -> d + +-- A slight extension of the Domain type from the paper. +-- Note that the 'Name's bear no semantic significance: The `Domain (D τ)` +-- instance simply ignores them. They are useful for analyses, however. +class Domain d where + stuck :: d + erased :: d -- Think of it like coercionToken# + lit :: Literal -> d + primOp :: PrimOp -> d + fun :: Name -> (d -> d) -> d + con :: DataCon -> [d] -> d + apply :: d -> d -> d + select :: d -> Name -> [DAlt d] -> d +type DAlt d = (AltCon, [Name], d -> [d] -> d) + +data BindHint = BindArg | BindNonRec Name | BindRec [Name] +class HasBind d where + bind :: BindHint -> [[d] -> d] -> ([d] -> d) -> d + -- NB: The `BindHint` bears no semantic sigificance: + -- `HasBind (D (ByNeed T))` does not look at it. + -- Still useful for analyses! + +seq_ :: Domain d => d -> d -> d +seq_ a b = select a wildCardName [(DEFAULT, [], \_a _ds -> b)] + +anfise :: (Trace d, Domain d, HasBind d) => CoreExpr -> IdEnv d -> (d -> d) -> d +anfise (Lit l) _ k = k (lit l) +anfise (Var x) env k | Just d <- lookupVarEnv env x = k d + | otherwise = stuck +anfise (Coercion co) env k = -- co is unlifted and will evaluate to coercionToken# + foldr (\x -> seq_ (eval (Var x) env)) (k erased) (NonDetUniqFM $ getUniqSet $ coVarsOfCo co) +anfise (Type _ty) _ k = k erased +anfise (Tick _t e) env k = anfise e env k +anfise (Cast e _co) env k = anfise e env k +anfise e env k = bind BindArg [const (step (LookupArg e) (eval e env))] + (\ds -> if isUnliftedType (exprType e) + then only ds `seq_` k (only ds) + else k (only ds)) + +anfiseMany :: (Trace d, Domain d, HasBind d) => [CoreExpr] -> IdEnv d -> ([d] -> d) -> d +anfiseMany es env k = go es [] + where + go [] ds = k (reverse ds) + go (e:es) ds = anfise e env $ \d -> go es (d:ds) + +eval :: (Trace d, Domain d, HasBind d) => CoreExpr -> IdEnv d -> d +eval (Coercion co) env = anfise (Coercion co) env id +eval (Type _ty) _ = erased +eval (Lit l) _ = lit l +eval (Tick _t e) env = eval e env +eval (Cast e _co) env = eval e env +eval (Var x) env + | Just dc <- isDataConWorkId_maybe x = con dc [] -- TODO + | Just op <- isPrimOpId_maybe x = primOp op + | isDataConWrapId x = eval (unfoldingTemplate (idUnfolding x)) emptyVarEnv + | Just d <- lookupVarEnv env x = d + | otherwise = stuck -- Scoping error. Actually ruled out by the Core type system +eval (Lam x e) env = fun (idName x) (\d -> step App2 (eval e (extendVarEnv env x d))) +eval e at App{} env + | Var v <- f, Just dc <- isDataConWorkId_maybe v + = anfiseMany as env $ \ds -> case compare (dataConRepArity dc) (length ds) of + EQ -> con dc ds + GT -> stuck -- oversaturated => stuck + LT -> expand [] (take (length ds - dataConRepArity dc) papNames) -- undersaturated => PAP + where + expand etas [] = con dc (ds ++ reverse etas) + expand etas (x:xs) = fun x (\d -> expand (d:etas) xs) + | otherwise + = go (eval f env) as + where + (f, as) = collectArgs e + go df [] = df + go df (a:as) = go (anfise a env (step App1 . apply df)) as +eval (Let (NonRec x rhs) body) env = + bind (BindNonRec (idName x)) + [const (step (Lookup (idName x)) (eval rhs env))] + (\ds -> step Let1 (eval body (extendVarEnv env x (only ds)))) +eval (Let (Rec binds) body) env = + bind (BindRec (map idName xs)) + [\ds -> step (Lookup (idName x)) (eval rhs (new_env ds)) | (x,rhs) <- binds] + (\ds -> step Let1 (eval body (new_env ds))) + where + xs = map fst binds + new_env ds = extendVarEnvList env (zip xs ds) +eval (Case e b _ty alts) env = step Case1 $ + select (eval e env) (idName b) + [ (con, map idName xs, cont xs rhs) | Alt con xs rhs <- alts ] + where + cont xs rhs scrut ds = step Case2 $ eval rhs (extendVarEnvList env (zipEqual "eval Case{}" (b:xs) (scrut:ds))) + +x1,x2 :: Name +papNames :: [Name] +papNames@(x1:x2:_) = [ mkSystemName (mkTempDataConArgUnique i) (mkVarOcc "pap") | i <- [0..] ] + + +-- By-need semantics, from the paper + +data T v = Step Event (T v) | Ret v + deriving Functor +instance Applicative T where pure = Ret; (<*>) = ap +instance Monad T where Ret a >>= f = f a; Step ev t >>= f = Step ev (t >>= f) +instance Trace (T v) where step = Step + +type D τ = τ (Value τ) +data Value τ + = Stuck + | Erased + | Litt Literal + | Fun (D τ -> D τ) + | Con DataCon [D τ] + +instance (Trace (D τ), Monad τ) => Domain (D τ) where + stuck = return Stuck + erased = return Erased + lit l = return (Litt l) + fun _x f = return (Fun f) + con k ds = return (Con k ds) + apply d a = d >>= \case Fun f -> f a; _ -> stuck + select d _b fs = d >>= \v -> case v of + Stuck -> stuck + Con k ds | Just (_con, _xs, f) <- findAlt (DataAlt k) fs -> f (return v) ds + Litt l | Just (_con, _xs, f) <- findAlt (LitAlt l) fs -> f (return v) [] + _ | Just (_con, _xs, f) <- findAlt DEFAULT fs -> f (return v) [] + _ -> stuck + primOp op = case op of + IntAddOp -> intop (+) + IntMulOp -> intop (*) + IntRemOp -> intop rem + _ -> stuck + where + intop op = binop (\v1 v2 -> case (v1,v2) of (Litt (LitNumber LitNumInt i1), Litt (LitNumber LitNumInt i2)) -> Litt (LitNumber LitNumInt (i1 `op` i2)); _ -> Stuck) + binop f = fun x1 $ \d1 -> step App2 $ fun x2 $ \d2 -> step App2 $ f <$> d1 <*> d2 + +-- The following function was copy and pasted from GHC.Core.Utils.findAlt: +findAlt :: AltCon -> [DAlt d] -> Maybe (DAlt d) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(DEFAULT, _, _):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(con1, _, _) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> go alts deflt + +-- By-need semantics, straight from the paper + +type Addr = Word64 +type Heap τ = WM.Word64Map (D τ) +newtype ByNeed τ v = ByNeed { runByNeed :: StateT (Heap (ByNeed τ)) τ v } + deriving (Functor, Applicative, Monad) + +instance (forall v. Trace (τ v)) => Trace (ByNeed τ v) where + step ev (ByNeed (StateT m)) = ByNeed $ StateT $ step ev . m + +fetch :: Monad τ => Addr -> D (ByNeed τ) +fetch a = ByNeed get >>= \μ -> μ WM.! a + +memo :: forall τ. (Monad τ, forall v. Trace (τ v)) => Addr -> D (ByNeed τ) -> D (ByNeed τ) +memo a d = d >>= ByNeed . StateT . upd + where upd Stuck μ = return (Stuck :: Value (ByNeed τ), μ) + upd v μ = step Update (return (v, WM.insert a (memo a (return v)) μ)) + +freeList :: Heap τ -> [Addr] +freeList μ = [a..] + where a = case WM.lookupMax μ of Just (a,_) -> a+1; _ -> 0 + +instance (Monad τ, forall v. Trace (τ v)) => HasBind (D (ByNeed τ)) where + bind _hint rhss body = do + as <- take (length rhss) . freeList <$> ByNeed get + let ds = map fetch as + ByNeed $ modify (\μ -> foldr (\(a,rhs) -> WM.insert a (memo a (rhs ds))) μ (zip as rhss)) + body ds + +evalByNeed :: CoreExpr -> T (Value (ByNeed T), Heap (ByNeed T)) +evalByNeed e = runStateT (runByNeed (eval e emptyVarEnv)) WM.empty + +-- Boilerplate +instance Outputable Event where + ppr (Lookup n) = text "Lookup" <> parens (ppr n) + ppr (LookupArg e) = text "LookupArg" <> parens (ppr e) + ppr Update = text "Update" + ppr App1 = text "App1" + ppr App2 = text "App2" + ppr Case1 = text "Case1" + ppr Case2 = text "Case2" + ppr Let1 = text "Let1" +instance Outputable v => Outputable (T v) where + ppr (Step ev τ) = ppr ev <> arrow <> ppr τ + ppr (Ret v) = char '<' <> ppr v <> char '>' +instance Outputable (Value τ) where + ppr Stuck = text "stuck" + ppr Erased = char '_' + ppr (Litt l) = ppr l + ppr (Fun _f) = text "Fun" + ppr (Con dc _ds) = ppr dc +instance Outputable (Heap τ) where + ppr μ = brackets (pprWithCommas (\(a,_) -> ppr a <> char '↦' <> underscore) (WM.toList μ)) ===================================== compiler/ghc.cabal.in ===================================== @@ -374,6 +374,7 @@ Library GHC.Core.Opt.WorkWrap.Utils GHC.Core.PatSyn GHC.Core.Ppr + GHC.Core.Semantics GHC.Types.TyThing.Ppr GHC.Core.Predicate GHC.Core.Reduction ===================================== ghdi.hs ===================================== @@ -0,0 +1,86 @@ +-- Import necessary modules +import GHC +import GHC.Driver.Config.Parser +import GHC.Driver.Env.Types +import GHC.Driver.Session +import GHC.Utils.Outputable +import GHC.Unit.Types +import GHC.Unit.Module.ModGuts +import GHC.Data.StringBuffer +import GHC.Data.FastString +import qualified GHC.Parser.Lexer as L +import qualified GHC.Parser as P +import GHC.Types.SrcLoc +import GHC.Core +import Control.Monad +import Control.Monad.IO.Class +import System.IO +import System.Environment +import System.Directory +import System.FilePath +import Data.List +import GHC.Types.Name +import GHC.Core.Semantics +import qualified GHC.LanguageExtensions as LangExt + +import System.Console.Haskeline + +--desugarFile :: GhcMonad m => FilePath -> m ModGuts +--desugarFile f = do +-- target <- guessTarget f Nothing Nothing +-- setTargets [ target ] +-- _successFlag <- load LoadAllTargets +-- mg <- hsc_mod_graph <$> getSession +-- let [ms] = mgModSummaries mg +-- m <- desugarModule =<< typecheckModule =<< parseModule ms +-- return (coreModule m) + +indent :: Int -> String -> String +indent n = unlines . map (\s -> replicate n ' ' ++ s) . lines + +processExpression :: String -> String -> IO CoreExpr +processExpression libdir expression = do + tmp <- getTemporaryDirectory + let file = tmp "_interactive_.hs" + writeFile file ("module Interactive where import GHC.Exts; it = " ++ indent 2 expression) + -- Initialize GHC session + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + runGhc (Just libdir) $ do + -- Set up GHC session + dflags <- getSessionDynFlags + setSessionDynFlags $ + -- flip gopt_unset Opt_FullLaziness $ + -- flip gopt_unset Opt_WorkerWrapper $ + -- updOptLevel 1 $ + flip gopt_unset Opt_LocalFloatOutTopLevel $ + flip gopt_set Opt_Specialise $ + flip gopt_unset Opt_IgnoreInterfacePragmas $ + flip xopt_set LangExt.MagicHash $ + dflags + mod_guts <- compileToCoreSimplified file + let binds = cm_binds mod_guts + let Just (NonRec _ e) = find (\b -> case b of NonRec x e -> getOccString x == "it"; _ -> False) binds + return e + +-- Main function to handle command-line arguments +main :: IO () +main = do + args <- getArgs + tmp <- getTemporaryDirectory + let settings = defaultSettings { historyFile = Just (tmp ".ghdi.hist") } + case args of + [libdir] -> runInputT settings (loop libdir) + _ -> putStrLn "Usage: `ghdi `, for example `ghdi $(ghc --print-libdir)`" + +loop :: FilePath -> InputT IO () +loop libdir = do + minput <- getInputLine "prompt> " + case minput of + Nothing -> return () + Just ":quit" -> return () + Just input -> do + e <- liftIO $ processExpression libdir input + outputStrLn (showSDocUnsafe (hang (text "Above expression as (optimised) Core:") 2 (ppr e))) + outputStrLn "Trace of denotational interpreter:" + outputStrLn (showSDocOneLine defaultSDocContext (hang empty 2 (ppr (evalByNeed e)))) + loop libdir View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d54222feb90f9ccdf63d2b89cd7bd582756bfb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d54222feb90f9ccdf63d2b89cd7bd582756bfb You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 18:16:20 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Sun, 07 Jan 2024 13:16:20 -0500 Subject: [Git][ghc/ghc][ghc-9.6] gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Message-ID: <659aea74da73b_1dbc90c5a9860572e0@gitlab.mail> Zubin pushed to branch ghc-9.6 at Glasgow Haskell Compiler / GHC Commits: f60d485c by Zubin Duggal at 2024-01-07T19:48:43+05:30 gitlab-ci: Use ghc 9.2.8 for generate_jobs_metadata Nix can't find ghc 9.2.4 for some reason, resulting in the lint-ci-config job failing Metric Decrease: MultiLayerModulesTH_Make Metric Increase: MultiLayerModulesTH_Make - - - - - 1 changed file: - .gitlab/generate_job_metadata Changes: ===================================== .gitlab/generate_job_metadata ===================================== @@ -1,5 +1,5 @@ #! /usr/bin/env nix-shell -#!nix-shell -i bash -p cabal-install "haskell.packages.ghc924.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq +#!nix-shell -i bash -p cabal-install "haskell.packages.ghc928.ghcWithPackages (pkgs: with pkgs; [aeson])" git jq cd "$(dirname "${BASH_SOURCE[0]}")" cabal run gen_ci -- metadata jobs-metadata.json View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f60d485c4ea9b58e65c54a552e5f6dda06270293 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f60d485c4ea9b58e65c54a552e5f6dda06270293 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 19:00:18 2024 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sun, 07 Jan 2024 14:00:18 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] 6 commits: Suppress orphan instance warning Message-ID: <659af4c2de492_1dbc90da4328059838@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: f78a1883 by Sven Tennie at 2024-01-07T19:56:54+01:00 Suppress orphan instance warning Similar to other archs, this seems to be the expected place. - - - - - af6771ae by Sven Tennie at 2024-01-07T19:58:08+01:00 Delete commented-out code - - - - - cc86c025 by Sven Tennie at 2024-01-07T19:58:52+01:00 Adjust panix message - - - - - 31b73f19 by Sven Tennie at 2024-01-07T19:59:19+01:00 Add TODOs - - - - - cd51abf6 by Sven Tennie at 2024-01-07T19:59:41+01:00 Formatting - - - - - 86dc6034 by Sven Tennie at 2024-01-07T19:59:52+01:00 Eta reduction - - - - - 4 changed files: - compiler/GHC/CmmToAsm/RV64.hs - compiler/GHC/CmmToAsm/RV64/CodeGen.hs - compiler/GHC/CmmToAsm/RV64/Ppr.hs - compiler/GHC/CmmToAsm/RV64/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64.hs ===================================== @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Native code generator for RiscV64 architectures module GHC.CmmToAsm.RV64 ( ncgRV64 ) ===================================== compiler/GHC/CmmToAsm/RV64/CodeGen.hs ===================================== @@ -544,7 +544,6 @@ getRegister' config plat expr = (op, imm_code) <- litToImm' lit let rep = cmmLitType plat lit format = cmmTypeFormat rep - -- width = typeWidth rep return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op)) CmmLabelOff lbl off -> do ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -324,9 +324,10 @@ pprReg w r = case r of RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u - _ -> pprPanic "AArch64.pprReg" (text $ show r) + _ -> pprPanic "RiscV64.pprReg" (text $ show r) where + -- TODO: Width is only used in error messages, so we could just remove it. ppr_reg_no :: Width -> Int -> doc -- General Purpose Registers ppr_reg_no _ 0 = text "zero" ===================================== compiler/GHC/CmmToAsm/RV64/Regs.hs ===================================== @@ -16,14 +16,15 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -allMachRegNos :: [RegNo] -allMachRegNos = [0..31] ++ [32..63] +allMachRegNos :: [RegNo] +allMachRegNos = [0 .. 31] ++ [32 .. 63] + -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the -- register allocator to attempt to map VRegs to. allocatableRegs :: Platform -> [RealReg] allocatableRegs platform - = let isFree i = freeReg platform i + = let isFree = freeReg platform in map RealRegSingle $ filter isFree allMachRegNos -- argRegs is the set of regs which are read for an n-argument call to C. @@ -45,6 +46,7 @@ allFpArgRegs = map regSingle [42..49] -- addressing modes ------------------------------------------------------------ +-- TODO: AddrRegReg constructor is never used. Remove it? data AddrMode = AddrRegReg Reg Reg | AddrRegImm Reg Imm View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fef187b4b52ac84140b50765301383c72104c8c4...86dc603457e8946c638ac439c4db5eff1f5aca98 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fef187b4b52ac84140b50765301383c72104c8c4...86dc603457e8946c638ac439c4db5eff1f5aca98 You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Sun Jan 7 20:30:02 2024 From: gitlab at gitlab.haskell.org (Jade (@Jade)) Date: Sun, 07 Jan 2024 15:30:02 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/three-way-merge-sort Message-ID: <659b09cadc17f_31a2c6117c554799d2@gitlab.mail> Jade pushed new branch wip/three-way-merge-sort at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/three-way-merge-sort You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 8 07:45:26 2024 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 08 Jan 2024 02:45:26 -0500 Subject: [Git][ghc/ghc][ghc-9.6] ci: Fix typo in mk_ghcup_metadata.py Message-ID: <659ba816a843_10e71e13a88148006@gitlab.mail> Zubin pushed to branch ghc-9.6 at Glasgow Haskell Compiler / GHC Commits: b3abeb84 by Zubin Duggal at 2024-01-08T13:15:07+05:30 ci: Fix typo in mk_ghcup_metadata.py - - - - - 1 changed file: - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py Changes: ===================================== .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py ===================================== @@ -138,7 +138,7 @@ def mk_one_metadata(release_mode, version, job_map, artifact): # So we must manually set the name of the bindist location if artifact == test_artifact: bindist_name = "testsuite" - else + else: bindist_name = fetch_gitlab.job_triple(artifact.job_name) final_url = release_base.format( version=version , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz")) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3abeb84d8b7e41954ad122b3411f3fcffc4e8da -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3abeb84d8b7e41954ad122b3411f3fcffc4e8da You're receiving this email because of your account on gitlab.haskell.org. -------------- next part -------------- An HTML attachment was scrubbed... URL: From gitlab at gitlab.haskell.org Mon Jan 8 08:18:55 2024 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 08 Jan 2024 03:18:55 -0500 Subject: [Git][ghc/ghc][wip/expand-do] Metric Increase 'compile_time/bytes allocated': Message-ID: <659bafef23d98_10e71e21caa3c818d@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: e8a6a298 by Apoorv Ingle at 2024-01-08T00:15:46-08:00 Metric Increase 'compile_time/bytes allocated': T9020 remove isGoodCoverateExpr. it is not needed. and simplifying the ticking logic - - - - - 6 changed files: - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Gen/Do.hs - testsuite/tests/hpc/fork/hpc_fork.stdout - testsuite/tests/hpc/function/tough.stdout - testsuite/tests/hpc/function2/tough2.stdout - testsuite/tests/hpc/simple/hpc001.stdout Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -375,7 +375,9 @@ addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage | isGoodCoverageExpr e0 -> tick_it + TickForCoverage | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately + -> dont_tick_it + | otherwise -> tick_it TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where @@ -393,7 +395,7 @@ addTickLHsExprRHS e@(L pos e0) = do case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it | otherwise -> tick_it - TickForCoverage | isGoodCoverageExpr e0 -> tick_it + TickForCoverage -> tick_it TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where @@ -409,8 +411,7 @@ addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprEvalInner e = do d <- getDensity case d of - TickForCoverage | isGoodCoverageExpr (unLoc e) -> addTickLHsExpr e - | otherwise -> addTickLHsExprNever e + TickForCoverage -> addTickLHsExprNever e _otherwise -> addTickLHsExpr e -- | A let body is treated differently from addTickLHsExprEvalInner @@ -441,31 +442,9 @@ addTickLHsExprNever (L pos e0) = do -- General heuristic: expressions which are calls (do not denote -- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (XExpr (ExpandedThingTc thing e)) - | OrigStmt (L _ BodyStmt{}) <- thing - = False - | OrigStmt (L _ BindStmt{}) <- thing - = False - | OrigStmt (L _ LastStmt{}) <- thing - = True - | otherwise - = isCallSite e +isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False isGoodBreakExpr e = isCallSite e --- Should coverage ticks be added to this expr? --- The general heuristic: Expanded `do`-stmts do not get --- the coverage ticks as they are accounted for in the expansions -isGoodCoverageExpr :: HsExpr GhcTc -> Bool -isGoodCoverageExpr (XExpr (ExpandedThingTc thing _)) - | OrigStmt (L _ BodyStmt{}) <- thing - = False - | OrigStmt (L _ BindStmt{}) <- thing - = False - | OrigStmt (L _ LetStmt{}) <- thing - = False -isGoodCoverageExpr _ = True - - isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppType{} = True @@ -476,21 +455,18 @@ isCallSite (XExpr (ExpandedThingTc _ e)) -- NB: OpApp, SectionL, SectionR are all expanded out isCallSite _ = False -addTickLHsExprOptAlt :: Bool -> Bool {- is do expansion -} - -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany isExpansion e@(L pos e0) - = if not (isExpansion) - then ifDensity TickForCoverage +addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprOptAlt oneOfMany e@(L pos e0) + = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False (locA pos) - $ addTickHsExpr e0) + $ addTickHsExpr e0) (addTickLHsExpr e) - else (addTickLHsExprNever e) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (L pos e0) +addBinTickLHsExpr boxLabel e@(L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) + (addTickLHsExpr e) -- ----------------------------------------------------------------------------- @@ -552,8 +528,8 @@ addTickHsExpr (HsCase x e mgs) = addTickHsExpr (HsIf x e1 e2 e3) = liftM3 (HsIf x) (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True False e2) - (addTickLHsExprOptAlt True False e3) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts @@ -613,9 +589,7 @@ addTickHsExpr (HsProc x pat cmdtop) = addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = liftM (XExpr . WrapExpr . HsWrap w) $ (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (XExpr (ExpandedThingTc o e)) = - liftM (XExpr . ExpandedThingTc o) $ - addTickHsExpr e +addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e addTickHsExpr e@(XExpr (ConLikeTc {})) = return e -- We used to do a freeVar on a pat-syn builder, but actually @@ -636,6 +610,21 @@ addTickHsExpr (HsDo srcloc cxt (L l stmts)) ListComp -> Just $ BinBox QualBinBox _ -> Nothing +addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded o@(OrigStmt (L pos LastStmt{})) e + -- LastStmt always gets a tick for breakpoint and hpc coverage + = do d <- getDensity + case d of + TickForCoverage -> liftM (XExpr . ExpandedThingTc o) $ tick_it e + TickForBreakPoints -> liftM (XExpr . ExpandedThingTc o) $ tick_it e + _ -> liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e + where + tick_it e = unLoc <$> allocTickBox (ExpBox False) False False (locA pos) + (addTickHsExpr e) +addTickHsExpanded o e + = liftM (XExpr . ExpandedThingTc o) $ addTickHsExpr e + + addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ; return (Present x e') } @@ -650,7 +639,7 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches return $ mg { mg_alts = L l matches' } -addTickMatch :: Bool -> Bool -> Bool {-Is Do Expanion-} -> Match GhcTc (LHsExpr GhcTc) +addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = pats , m_grhss = gRHSs }) = @@ -680,10 +669,15 @@ addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do d <- getDensity case d of TickForBreakPoints - | XExpr (ExpandedThingTc thing _) <- e0 - , OrigStmt (L _ LastStmt{}) <- thing -> addTickLHsExprRHS expr - | isDoExp -> addTickLHsExprNever expr - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany isDoExp expr + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprRHS expr + TickForCoverage + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprOptAlt isOneOfMany expr TickAllFunctions | isLambda -> addPathEntry "\\" $ allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ @@ -1093,6 +1087,7 @@ instance Monad TM where (r2,fv2,st2) -> (r2, fv1 `plusOccEnv` fv2, st2) + -- | Get the next HPC cost centre index for a given centre name getCCIndexM :: FastString -> TM CostCentreIndex getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ @@ -1175,8 +1170,8 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)) - ) (do + return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))) + (do e <- m return (L (noAnnSrcSpan pos) e) ) ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -91,7 +91,7 @@ expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))] | NoSyntaxExprRn <- ret_expr -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt = do traceTc "expand_do_stmts last" (ppr ret_expr) - return $ mkExpandedStmtPopAt body_loc stmt body + return $ mkExpandedStmtPopAt loc stmt body | SyntaxExprRn ret <- ret_expr -- @@ -185,7 +185,8 @@ expand_do_stmts do_or_lc do_block :: LHsExpr GhcRn do_block = L loc $ HsDo noExtField do_or_lc do_stmts mfix_expr :: LHsExpr GhcRn - mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block + mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] + $ do_block -- NB: LazyPat because we do not want to eagerly evaluate the pattern -- and potentially loop forever @@ -196,9 +197,9 @@ mk_failable_expr :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator G mk_failable_expr doFlav pat@(L loc _) expr fail_op = do { is_strict <- xoptM LangExt.Strict ; irrf_pat <- isIrrefutableHsPatRnTcM is_strict pat - ; traceTc "mk_fail_expr" (vcat [ text "pat:" <+> ppr pat - , text "isIrrefutable:" <+> ppr irrf_pat - ]) + ; traceTc "mk_failable_expr" (vcat [ text "pat:" <+> ppr pat + , text "isIrrefutable:" <+> ppr irrf_pat + ]) ; if irrf_pat -- don't wrap with fail block if -- the pattern is irrefutable @@ -210,7 +211,7 @@ mk_failable_expr doFlav pat@(L loc _) expr fail_op = mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn) mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) = do dflags <- getDynFlags - return $ HsLam noAnn LamSingle $ mkMatchGroup (doExpansionMatchOrigin doFlav) -- \ + return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionMatchOrigin doFlav) -- \ (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern" ]) ===================================== testsuite/tests/hpc/fork/hpc_fork.stdout ===================================== @@ -1,7 +1,7 @@ () - 60% expressions used (6/10) + 53% expressions used (7/13) 100% boolean coverage (0/0) 100% guards (0/0) 100% 'if' conditions (0/0) @@ -12,7 +12,7 @@ ---------- - 60% expressions used (6/10) + 53% expressions used (7/13) 100% boolean coverage (0/0) 100% guards (0/0) 100% 'if' conditions (0/0) @@ -67,10 +67,10 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } - + - +
moduleTop Level DefinitionsAlternativesExpressions
%covered / total%covered / total%covered / total
  module Main100%1/1
- 0/0 60%6/10
100%1/1
- 0/0 53%7/13
  Program Coverage Total100%1/1
- 0/0 60%6/10
100%1/1
- 0/0 53%7/13
Writing: hpc_index_fun.html