From gitlab at gitlab.haskell.org Fri Dec 1 07:23:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 01 Dec 2023 02:23:27 -0500 Subject: [Git][ghc/ghc][wip/24107] driver: Ensure we force the lookup of old build artifacts before returning the build plan Message-ID: <656989efe1731_e924e84488bfc7052e0@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: cb55e42f by Zubin Duggal at 2023-12-01T12:35:17+05:30 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 - - - - - 1 changed file: - compiler/GHC/Driver/Make.hs Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb55e42f7808a87d83828523b0d5c7c97e3cd00b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb55e42f7808a87d83828523b0d5c7c97e3cd00b 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 Dec 1 10:32:50 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 01 Dec 2023 05:32:50 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24234 Message-ID: <6569b65289e5_e924e88a80f88732045@gitlab.mail> Sebastian Graf pushed new branch wip/T24234 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24234 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 Dec 1 11:15:08 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 01 Dec 2023 06:15:08 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: perf tests: Move comments into new `Note [Sensitivity to unique increment]` (#19414) Message-ID: <6569c03c2d805_e924e89d7b2b4742839@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 04fd6490 by Matthew Pickering at 2023-12-01T06:14:53-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. - - - - - 38d385e3 by Matthew Pickering at 2023-12-01T06:14:54-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 - - - - - 7609c33e by Matthew Pickering at 2023-12-01T06:14:54-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 22 changed files: - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Tc/Gen/HsType.hs - testsuite/driver/testlib.py - testsuite/tests/dependent/should_fail/T16326_Fail12.stderr - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - testsuite/tests/perf/compiler/T12545.hs - testsuite/tests/perf/compiler/T13386.hs - testsuite/tests/perf/compiler/T8095.hs - testsuite/tests/perf/compiler/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/vdq-rta/should_fail/T24176.hs - + testsuite/tests/vdq-rta/should_fail/T24176.stderr - testsuite/tests/vdq-rta/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Types.hs - utils/check-exact/Utils.hs - utils/haddock Changes: ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Parser.Annotation ( -- * In-tree Exact Print Annotations AddEpAnn(..), - EpaLocation(..), epaLocationRealSrcSpan, + EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan, TokenLocation(..), getTokenSrcSpan, DeltaPos(..), deltaPos, getDeltaLine, @@ -26,7 +26,8 @@ module GHC.Parser.Annotation ( -- ** Comments in Annotations - EpAnnComments(..), LEpaComment, emptyComments, + EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments, + epaToNoCommentsLocation, noCommentsToEpaLocation, getFollowingComments, setFollowingComments, setPriorComments, EpAnnCO, @@ -402,9 +403,26 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- in the @'EpaDelta'@ variant captures any comments between the prior -- output and the thing being marked here, since we cannot otherwise -- sort the relative order. -data EpaLocation = EpaSpan !SrcSpan - | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq,Show) + +data EpaLocation' a = EpaSpan !SrcSpan + | EpaDelta !DeltaPos !a + deriving (Data,Eq,Show) + +type EpaLocation = EpaLocation' [LEpaComment] + +type NoCommentsLocation = EpaLocation' NoComments + +data NoComments = NoComments + deriving (Data,Eq,Ord,Show) + +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation +epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss +epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments +epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation" + +noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation +noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss +noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp [] -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). @@ -454,7 +472,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" -instance Outputable EpaLocation where +instance Outputable NoComments where + ppr NoComments = text "NoComments" + +instance (Outputable a) => Outputable (EpaLocation' a) where ppr (EpaSpan r) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs @@ -517,18 +538,18 @@ data EpAnn ann -- that relationship is tracked in the 'anchor_op' instead. type Anchor = EpaLocation -- Transitional -anchor :: Anchor -> RealSrcSpan +anchor :: (EpaLocation' a) -> RealSrcSpan anchor (EpaSpan (RealSrcSpan r _)) = r anchor _ = panic "anchor" -spanAsAnchor :: SrcSpan -> Anchor +spanAsAnchor :: SrcSpan -> (EpaLocation' a) spanAsAnchor ss = EpaSpan ss -realSpanAsAnchor :: RealSrcSpan -> Anchor +realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a) realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) -noSpanAnchor :: Anchor -noSpanAnchor = EpaDelta (SameLine 0) [] +noSpanAnchor :: (NoAnn a) => (EpaLocation' a) +noSpanAnchor = EpaDelta (SameLine 0) noAnn -- --------------------------------------------------------------------- @@ -546,7 +567,7 @@ data EpAnnComments = EpaComments , followingComments :: ![LEpaComment] } deriving (Data, Eq) -type LEpaComment = GenLocated Anchor EpaComment +type LEpaComment = GenLocated NoCommentsLocation EpaComment emptyComments :: EpAnnComments emptyComments = EpaComments [] @@ -1333,7 +1354,7 @@ instance Outputable DeltaPos where ppr (SameLine c) = text "SameLine" <+> ppr c ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c -instance Outputable (GenLocated Anchor EpaComment) where +instance Outputable (GenLocated NoCommentsLocation EpaComment) where ppr (L l c) = text "L" <+> ppr l <+> ppr c instance Outputable EpAnnComments where ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1178,17 +1178,30 @@ tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls -tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind - = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ - tc_lhs_type mode ty exp_kind +tc_hs_type mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + | HsForAllInvis{} <- tele + = tc_hs_forall_ty tele ty exp_kind + -- For an invisible forall, we allow the body to have + -- an arbitrary kind (hence exp_kind above). + -- See Note [Body kind of a HsForAllTy] + + | HsForAllVis{} <- tele + = do { ek <- newOpenTypeKind + ; r <- tc_hs_forall_ty tele ty ek + ; checkExpectedKind t r ek exp_kind } + -- For a visible forall, we require that the body is of kind TYPE r. + -- See Note [Body kind of a HsForAllTy] + + where + tc_hs_forall_ty tele ty ek + = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ + tc_lhs_type mode ty ek -- Pass on the mode from the type, to any wildcards -- in kind signatures on the forall'd variables -- e.g. f :: _ -> Int -> forall (a :: _). blah - -- Why exp_kind? See Note [Body kind of a HsForAllTy] - -- Do not kind-generalise here! See Note [Kind generalisation] - - ; return (mkForAllTys tv_bndrs ty') } + -- Do not kind-generalise here! See Note [Kind generalisation] + ; return (mkForAllTys tv_bndrs ty') } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt) @@ -2042,25 +2055,23 @@ examples. Note [Body kind of a HsForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see +The body of a forall is usually a type. +Because of representation polymorphism, it can be a TYPE r, for any r. +(In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all via CPR analysis; see typecheck/should_compile/tc170). -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is (TYPE _). But this is -wrong. For example: +A forall can also be used in an instance head, then the body should +be a constraint. - class C a b - newtype N = Mk Foo deriving (C a) +Right now, we do not have any easy way to enforce that a type is +either a TYPE something or CONSTRAINT something, so we accept any kind. +This is unsound (#22063). We could fix this by implementing a TypeLike +predicate, see #20000. -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for (TYPE _) here. +For a forall with a required argument, we do not allow constraints; +e.g. forall a -> Eq a is invalid. Therefore, we can enforce that the body +is a TYPE something in this case (#24176). Note [Body kind of a HsQualTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/dependent/should_fail/T16326_Fail12.stderr ===================================== @@ -1,8 +1,8 @@ -T16326_Fail12.hs:6:1: error: [GHC-51580] - • Illegal visible, dependent quantification in the type of a term: - forall a -> Show a - • In the context: forall a -> Show a - While checking the super-classes of class ‘C’ - In the class declaration for ‘C’ - Suggested fix: Perhaps you intended to use RequiredTypeArguments +T16326_Fail12.hs:6:8: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Show a’ is a type + • In the class declaration for ‘C’ + +T16326_Fail12.hs:6:20: error: [GHC-83865] + • Expected a type, but ‘Show a’ is a constraint + • In the class declaration for ‘C’ ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/compiler/T12545.hs ===================================== @@ -15,6 +15,29 @@ type instance ElemsOf A = [ T1, T2, T3, T4, T5, T6, T7, T8 , T25, T26, T27, T28, T29, T30, T31, T32 ] +{- Note [Sensitivity to unique increment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T12545 is sensitive to -dunique-increments changes, see #19414. I've seen +variations of as much as 4.8% by playing with that parameter. + +The issue with this test is that it does too little so is very sensitive to +any small variations during initialisation and in particular populating the +initial environments with wired-in things. Therefore it has a very high change +threshold so we catch if it regresses a lot but don't worry if it regresses a little. + +You can measure the variance by running T12545.measure.sh. + +Whenever we identify such a test (T8095 being another example), we leave a link +to this Note in the source code of the test *and* in the corresponding all.T, +detailing the spread as measured by adjusting T12545.measure.sh. +For example, + +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% + +and then double the spread to come up with a stable acceptance threshold (e.g., +10%). +-} + data T1; instance ElemOf A T1 where data T2; instance ElemOf A T2 where data T3; instance ElemOf A T3 where ===================================== testsuite/tests/perf/compiler/T13386.hs ===================================== @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -O0 -freduction-depth=500 #-} - +-- Subject to Note [Sensitivity to unique increment] with spread of 1.5% module T13386 where import GHC.TypeLits ===================================== testsuite/tests/perf/compiler/T8095.hs ===================================== @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -freduction-depth=1000 #-} {-# LANGUAGE TypeOperators,DataKinds,KindSignatures,TypeFamilies,PolyKinds,UndecidableInstances #-} +-- Subject to Note [Sensitivity to unique increment] with spread of 1.7% import GHC.TypeLits data Nat1 = Zero | Succ Nat1 type family Replicate1 (n :: Nat1) (x::a) :: [a] @@ -16,4 +17,3 @@ instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ f X = Y f Y = X test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) () )) - ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -167,14 +167,18 @@ test('T9872d', ], compile, ['']) +# Since major improvements to T8095 in in +# 4bf9fa0f216bb294c1bd3644363b008a8643a653 it is subject to +# Note [Sensitivity to unique increment] in T12545.hs; spread was 1.7% test ('T8095', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',2) ], + collect_compiler_stats('bytes allocated',4) ], compile, ['-v0 -O']) +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 1.5% test ('T13386', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',1) ], + collect_compiler_stats('bytes allocated',3) ], compile, ['-v0 -O0']) @@ -261,15 +265,7 @@ test('T12234', compile, ['']) -# T12545 is sensitive to -dunique-increments changes, see #19414. I've seen -# variations of as much as 4.8% by playing with that parameter, -# -# The issue with the test is that it does too little so is very sensitive to -# any small variations during initialisation and in particular populating the -# initial environments with wired-in things. Therefore it has a very high change -# threshold so we catch if it regresses a lot but don't worry if it regresses a little. -# -# You can measure the variance by running T12545.measure.sh. +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% test('T12545', [ only_ways(['normal']), collect_compiler_stats('bytes allocated', 10), # ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -17,7 +17,8 @@ { Test20297.hs:11:22-26 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.hs:1:1-33 }) + (EpaSpan + { Test20297.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") @@ -114,7 +115,8 @@ (AddEpAnn AnnEqual (EpaSpan { Test20297.hs:5:5 }))) (EpaComments [(L - (EpaSpan { Test20297.hs:6:3-13 }) + (EpaSpan + { Test20297.hs:6:3-13 }) (EpaComment (EpaLineComment "-- comment0") @@ -162,7 +164,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:7:9-19 }) + (EpaSpan + { Test20297.hs:7:9-19 }) (EpaComment (EpaLineComment "-- comment1") @@ -267,7 +270,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:10:9-19 }) + (EpaSpan + { Test20297.hs:10:9-19 }) (EpaComment (EpaLineComment "-- comment2") @@ -436,7 +440,8 @@ { Test20297.ppr.hs:9:20-24 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.ppr.hs:1:1-33 }) + (EpaSpan + { Test20297.ppr.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") ===================================== testsuite/tests/vdq-rta/should_fail/T24176.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE QuantifiedConstraints, RequiredTypeArguments #-} +module T24176 where + +f :: (forall a -> Eq a) => a +f = f ===================================== testsuite/tests/vdq-rta/should_fail/T24176.stderr ===================================== @@ -0,0 +1,8 @@ + +T24176.hs:4:7: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Eq a’ is a type + • In the type signature: f :: (forall a -> Eq a) => a + +T24176.hs:4:19: error: [GHC-83865] + • Expected a type, but ‘Eq a’ is a constraint + • In the type signature: f :: (forall a -> Eq a) => a ===================================== testsuite/tests/vdq-rta/should_fail/all.T ===================================== @@ -14,4 +14,5 @@ test('T22326_fail_patsyn', normal, compile_fail, ['']) test('T22326_fail_match', normal, compile_fail, ['']) test('T23738_fail_wild', normal, compile_fail, ['']) test('T23738_fail_implicit_tv', normal, compile_fail, ['']) -test('T23738_fail_var', normal, compile_fail, ['']) \ No newline at end of file +test('T23738_fail_var', normal, compile_fail, ['']) +test('T24176', normal, compile_fail, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -619,7 +619,7 @@ annotationsToComments (EpAnn anc a cs) l kws = do go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) go acc [] = acc go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls + | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls | otherwise = go (cs', (AddEpAnn k ss):ans) ls -- --------------------------------------------------------------------- @@ -677,7 +677,7 @@ printStringAtRsC capture pa str = do NoCaptureComments -> return [] debugM $ "printStringAtRsC:cs'=" ++ show cs' debugM $ "printStringAtRsC:p'=" ++ showAst p' - debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments) debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) return (EpaDelta p' (map comment2LEpaComment cs')) @@ -1365,14 +1365,14 @@ printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsBefore ss = do cs <- commentAllocationBefore ss debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsIn ss = do cs <- commentAllocationIn ss debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs debugM $ "printCommentsIn:done" @@ -1423,12 +1423,12 @@ updateAndApplyComment (Comment str anc pp mo) dp = do _ -> dp'' op' = case dp' of SameLine n -> if n >= 0 - then EpaDelta dp' [] - else EpaDelta dp [] - _ -> EpaDelta dp' [] - anc' = if str == "" && op' == EpaDelta (SameLine 0) [] -- EOF comment - then EpaDelta dp [] - else EpaDelta dp [] + then EpaDelta dp' NoComments + else EpaDelta dp NoComments + _ -> EpaDelta dp' NoComments + anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment + then EpaDelta dp NoComments + else EpaDelta dp NoComments -- --------------------------------------------------------------------- ===================================== utils/check-exact/Main.hs ===================================== @@ -68,6 +68,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6) + -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3) ===================================== utils/check-exact/Transform.hs ===================================== @@ -283,8 +283,9 @@ setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp (dp0,c') = go h in (dp0, c':t, EpaCommentsBalanced [] ts) + go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e) go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c) - go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) + go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c) setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp = case sortEpaComments (priorComments cs) of [] -> @@ -293,7 +294,7 @@ setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp L (EpAnn (EpaDelta edp csd) an cs'') a where cs'' = setPriorComments cs [] - csd = L (EpaDelta dp []) c:cs' + csd = L (EpaDelta dp NoComments) c:cs' lc = last $ (L ca c:cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r ===================================== utils/check-exact/Types.hs ===================================== @@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators - , commentAnchor :: !Anchor + , commentLoc :: !NoCommentsLocation , commentPriorTok :: !RealSrcSpan , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } ===================================== utils/check-exact/Utils.hs ===================================== @@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0 -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) - = (L (EpaDelta dp []) (GHC.EpaComment t pp)) + = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp)) `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp)) where (r,c) = ss2posEnd pp @@ -253,7 +253,7 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s tokComment :: LEpaComment -> [Comment] tokComment t@(L lt c) = case c of - (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc + (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] @@ -268,9 +268,9 @@ hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = in (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs)) hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk)) - = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments anc pt (NestedDocString dec (L _ chunk)) - = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code @@ -301,11 +301,11 @@ mkEpaComments priorCs postCs comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r -mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment -mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r)) +mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment +mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r)) -mkComment :: String -> Anchor -> RealSrcSpan -> Comment -mkComment c anc r = Comment c anc r Nothing +mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment +mkComment c loc r = Comment c loc r Nothing -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String @@ -328,11 +328,11 @@ sortEpaComments cs = sortBy cmp cs cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> EpaLocation -> Comment +mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) mkKWComment kw (EpaSpan (UnhelpfulSpan _)) - = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw) + = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta dp cs) = Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw) @@ -481,7 +481,7 @@ hsDeclsClassDecl dec = case dec of tcdATs = ats, tcdATDefs = at_defs } -> map snd decls where - srs :: (HasLoc a) => a -> RealSrcSpan + srs :: EpAnn a -> RealSrcSpan srs a = realSrcSpan $ locA a decls = orderedDecls sortKey $ Map.fromList ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a +Subproject commit a7eae7da6868b22dc7109142475b228c60509812 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a54f765ee0e4dd6368ce1790267c23cd55eea619...7609c33ec799c98e2ff10444f4b0a7a2cea560d1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a54f765ee0e4dd6368ce1790267c23cd55eea619...7609c33ec799c98e2ff10444f4b0a7a2cea560d1 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 Dec 1 11:20:39 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 01 Dec 2023 06:20:39 -0500 Subject: [Git][ghc/ghc][wip/24107] 3 commits: compiler: Add some strictness annotations to ImportSpec and related constructors Message-ID: <6569c18740df5_e924e8975c0b8747631@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 8b9acb6b by Zubin Duggal at 2023-12-01T16:46:01+05:30 compiler: Add some strictness annotations to ImportSpec and related constructors This prevents us from retain entire HscEnvs. Fixes #24107 - - - - - bd274de5 by Zubin Duggal at 2023-12-01T16:46:01+05:30 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 - - - - - 3a131559 by Zubin Duggal at 2023-12-01T16:50:30+05:30 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 - - - - - 4 changed files: - compiler/GHC/Driver/Make.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Types/Name/Reader.hs - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -1202,7 +1202,7 @@ filterImports hsc_env iface decl_spec Nothing = return (Nothing, gresFromAvails hsc_env (Just imp_spec) all_avails) where all_avails = mi_exports iface - imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + !imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names @@ -1582,7 +1582,7 @@ gresFromIE decl_spec (L loc ie, gres) item_spec = ImpSome { is_explicit = is_explicit name , is_iloc = locA loc } set_gre_imp gre@( GRE { gre_name = nm } ) - = gre { gre_imp = unitBag $ prov_fn nm } + = gre { gre_imp = unitBag $! prov_fn nm } {- Note [Children for duplicate record fields] ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -1916,8 +1916,8 @@ instance Semigroup ShadowedGREs where -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) -- | Import Declaration Specification @@ -1926,15 +1926,15 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1945,8 +1945,8 @@ data ImpItemSpec -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -392,6 +392,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefsReload'), + extra_files(['genMultiLayerModulesDefsReload']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb55e42f7808a87d83828523b0d5c7c97e3cd00b...3a131559536dd9e7d704b10d3f0baf2fdc7bee61 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cb55e42f7808a87d83828523b0d5c7c97e3cd00b...3a131559536dd9e7d704b10d3f0baf2fdc7bee61 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 Dec 1 11:21:41 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 01 Dec 2023 06:21:41 -0500 Subject: [Git][ghc/ghc][wip/24107] testsuite: add test for #24118 and #24107 Message-ID: <6569c1c556d60_e924e8a1e2b7c748037@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: dd7ac68f by Zubin Duggal at 2023-12-01T16:51:34+05:30 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 - - - - - 3 changed files: - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T - + testsuite/tests/perf/compiler/genMultiLayerModulesDefsReload Changes: ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -392,6 +392,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefsReload'), + extra_files(['genMultiLayerModulesDefsReload']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), ===================================== testsuite/tests/perf/compiler/genMultiLayerModulesDefsReload ===================================== @@ -0,0 +1,26 @@ +#!/usr/bin/env bash +# Generate $DEPTH layers of modules with $WIDTH modules on each layer +# Every module on layer N imports all the modules on layer N-1 +# Each module has $DEFS definitions in +# MultiLayerModules.hs imports all the modules from the last layer +DEPTH=3 +WIDTH=3 +DEFS=1000 +for i in $(seq -w 1 $WIDTH); do + echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs; +done +for l in $(seq 1 $DEPTH); do + for i in $(seq -w 1 $WIDTH); do + echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs; + for j in $(seq -w 1 $WIDTH); do + echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs; + done + for k in $(seq -w 1 $DEFS); do + echo "a_${l}_${i}_${j}_${k} = ${l} + ${i} + ${j} + ${k}" >> DummyLevel${l}M$i.hs; + done + done +done +echo "module MultiLayerModules where" > MultiLayerModules.hs +for j in $(seq -w 1 $WIDTH); do + echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs; +done View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd7ac68f6002943af7311b8daba76cc8e75d7b02 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dd7ac68f6002943af7311b8daba76cc8e75d7b02 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 Dec 1 11:23:17 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 01 Dec 2023 06:23:17 -0500 Subject: [Git][ghc/ghc][wip/24107] testsuite: add test for #24118 and #24107 Message-ID: <6569c22510b3d_e924e8a3a9960748478@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 84458053 by Zubin Duggal at 2023-12-01T16:53:10+05:30 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 - - - - - 2 changed files: - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T Changes: ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -392,6 +392,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefs'), + extra_files(['genMultiLayerModulesDefs']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84458053eb48f5e74c2c170b16f570f171030784 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/84458053eb48f5e74c2c170b16f570f171030784 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 Dec 1 12:44:31 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Fri, 01 Dec 2023 07:44:31 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/forall-kind-rule Message-ID: <6569d52feac01_e924e8c1fac2075582@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/forall-kind-rule at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/forall-kind-rule 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 Dec 1 12:49:24 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 01 Dec 2023 07:49:24 -0500 Subject: [Git][ghc/ghc][wip/T24234] Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234) Message-ID: <6569d654cfac2_e924e8c1f7a20757736@gitlab.mail> Sebastian Graf pushed to branch wip/T24234 at Glasgow Haskell Compiler / GHC Commits: d46c4987 by Sebastian Graf at 2023-12-01T13:49:17+01: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". - - - - - 12 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Utils.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/ado/T22483.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - + testsuite/tests/pmcheck/should_compile/T24234.hs - + testsuite/tests/pmcheck/should_compile/T24234.stderr - testsuite/tests/pmcheck/should_compile/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1469,6 +1469,21 @@ pprGRHS ctxt (GRHS _ guards body) pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator LamAlt{} = text "->" +matchSeparator IfAlt = text "->" +matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern +matchSeparator PatSyn = text "<-" -- match checker trace +matchSeparator LazyPatCtx = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" + instance Outputable GrhsAnn where ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s @@ -1931,6 +1946,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where ppr ThPatSplice = text "ThPatSplice" ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" + ppr LazyPatCtx = text "LazyPatCtx" instance Outputable HsLamVariant where ppr = text . \case @@ -1981,6 +1997,7 @@ matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (Stm matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour +matchContextErrString LazyPatCtx = text "irrefutable pattern" matchArrowContextErrString :: HsArrowMatchContext -> SDoc matchArrowContextErrString ProcExpr = text "proc" @@ -2022,20 +2039,6 @@ pprStmtInCtxt ctxt stmt , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt -matchSeparator :: HsMatchContext p -> SDoc -matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator StmtCtxt{} = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern -matchSeparator PatSyn = text "<-" -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" - pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContext ctxt @@ -2045,6 +2048,7 @@ pprMatchContext ctxt want_an (FunRhs {}) = True -- Use "an" in front want_an (ArrowMatchCtxt ProcExpr) = True want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True + want_an LazyPatCtx = True want_an _ = False pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) @@ -2065,6 +2069,7 @@ pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration" +pprMatchContextNoun LazyPatCtx = text "irrefutable pattern" pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -237,7 +237,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss ; body_expr <- dsGuarded grhss ty rhss_nablas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body' -- We silently ignore inline pragmas; no makeCorePair -- Not so cool, but really doesn't matter ; let force_var' = if isBangedLPat pat' ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -451,13 +451,13 @@ tidy1 v _ (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) + = putSrcSpanDs (getLocA pat) $ + do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLocA pat) $ diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } ===================================== compiler/GHC/HsToCore/Pmc.hs ===================================== @@ -118,6 +118,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p then id else discardWarningsDs want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True want_pmc (StmtCtxt stmt_ctxt) = case stmt_ctxt of PatGuard {} -> False ===================================== compiler/GHC/HsToCore/Pmc/Utils.hs ===================================== @@ -91,6 +91,7 @@ exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd +exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing exhaustiveWarningFlag ThPatQuote = Nothing ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -726,15 +726,16 @@ work out well: -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced. -mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound +mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> HsMatchContext GhcTc -- ^ Where the pattern occurs + -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") -- and all the desugared binds -mkSelectorBinds ticks pat val_expr +mkSelectorBinds ticks pat ctx val_expr | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) @@ -745,7 +746,7 @@ mkSelectorBinds ticks pat val_expr ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + = do { rhs_expr <- matchSimply (Var val_var) ctx pat' (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the @@ -760,7 +761,7 @@ mkSelectorBinds ticks pat val_expr | otherwise -- General case (C) = do { tuple_var <- newSysLocalDs ManyTy tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat + ; tuple_expr <- matchSimply val_expr ctx pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -1576,6 +1576,7 @@ data HsMatchContext p | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration + | LazyPatCtx -- ^An irrefutable pattern {- Note [mc_fun field of FunRhs] ===================================== testsuite/tests/ado/T22483.stderr ===================================== @@ -2,7 +2,7 @@ T22483.hs:1:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: main :: IO () -T22483.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] +T22483.hs:4:4: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] Pattern match(es) are non-exhaustive - In a pattern binding: + In an irrefutable pattern: Patterns of type ‘Maybe ()’ not matched: Nothing ===================================== testsuite/tests/deSugar/should_run/dsrun008.stderr ===================================== @@ -1,2 +1,2 @@ -dsrun008: dsrun008.hs:2:15-42: Non-exhaustive patterns in (2, x) +dsrun008: dsrun008.hs:2:32-36: Non-exhaustive patterns in (2, x) ===================================== testsuite/tests/pmcheck/should_compile/T24234.hs ===================================== @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -W #-} + +module T24234 where + +foo :: [()] -> () +foo ~(a:_) = a +foo _ = () ===================================== testsuite/tests/pmcheck/should_compile/T24234.stderr ===================================== @@ -0,0 +1,8 @@ + +T24234.hs:6:6: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] + Pattern match(es) are non-exhaustive + In an irrefutable pattern: Patterns of type ‘[()]’ not matched: [] + +T24234.hs:7:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘foo’: foo _ = ... ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -120,6 +120,7 @@ test('T19271', [], compile, [overlapping_incomplete]) test('T21761', [], compile, [overlapping_incomplete]) test('T22964', [], compile, [overlapping_incomplete]) test('T23445', [], compile, [overlapping_incomplete]) +test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns']) # Series (inspired) by Luke Maranget @@ -166,4 +167,4 @@ test('EmptyCase009', [], compile, [overlapping_incomplete]) test('EmptyCase010', [], compile, [overlapping_incomplete]) test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors']) test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors']) -test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) \ No newline at end of file +test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d46c49872e7b3d01abf65b78f2e4cc712a8e8f0b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d46c49872e7b3d01abf65b78f2e4cc712a8e8f0b 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 Dec 1 13:26:17 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 01 Dec 2023 08:26:17 -0500 Subject: [Git][ghc/ghc][wip/24107] 57 commits: Suppress duplicate librares linker warning of new macOS linker Message-ID: <6569def9d2657_e924e8d2f89b4758089@gitlab.mail> Matthew Pickering pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 3548338e by Zubin Duggal at 2023-12-01T13:26:10+00: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 - - - - - 909059f3 by Zubin Duggal at 2023-12-01T13:26:10+00:00 compiler: Add some strictness annotations to ImportSpec and related constructors This prevents us from retain entire HscEnvs. Fixes #24107 - - - - - 0e1b09f5 by Zubin Duggal at 2023-12-01T13:26:10+00: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 - - - - - 42c4620d by Zubin Duggal at 2023-12-01T13:26:10+00: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 - - - - - 30 changed files: - .gitlab/merge_request_templates/Default.md - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.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 - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Linker/Dynamic.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84458053eb48f5e74c2c170b16f570f171030784...42c4620d9df1eaceb4b8ebeeba8a5fa22f44f254 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84458053eb48f5e74c2c170b16f570f171030784...42c4620d9df1eaceb4b8ebeeba8a5fa22f44f254 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 Dec 1 15:15:52 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 01 Dec 2023 10:15:52 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: testsuite: Fix T21097b test with make 4.1 (deb9) Message-ID: <6569f8a89f5b8_e924e90142fcc8376b5@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 079d4bb2 by Matthew Pickering at 2023-12-01T10:15:34-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. - - - - - c73a10a0 by Matthew Pickering at 2023-12-01T10:15:35-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 - - - - - 97d04881 by Matthew Pickering at 2023-12-01T10:15:35-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 5 changed files: - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7609c33ec799c98e2ff10444f4b0a7a2cea560d1...97d04881488fc3b2c35f3393151bd11f7750ca7f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7609c33ec799c98e2ff10444f4b0a7a2cea560d1...97d04881488fc3b2c35f3393151bd11f7750ca7f 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 Dec 1 20:16:03 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 01 Dec 2023 15:16:03 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: testsuite: Fix T21097b test with make 4.1 (deb9) Message-ID: <656a3f0337072_319fc122e00fc55810@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f1e1f0f2 by Matthew Pickering at 2023-12-01T15:15:54-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. - - - - - d0aaf0af by Matthew Pickering at 2023-12-01T15:15:55-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 - - - - - 5504f77c by Matthew Pickering at 2023-12-01T15:15:55-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 5 changed files: - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97d04881488fc3b2c35f3393151bd11f7750ca7f...5504f77c7fe3633190c045e4816d9afc13e4882d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/97d04881488fc3b2c35f3393151bd11f7750ca7f...5504f77c7fe3633190c045e4816d9afc13e4882d 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 Dec 1 23:46:46 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 01 Dec 2023 18:46:46 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656a7066cfc2a_319fc17489c8c7936@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 01f312ee by Owen Shepherd at 2023-12-01T18:46:39-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - acb9ff34 by Owen Shepherd at 2023-12-01T18:46:39-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 0a26823d by Owen Shepherd at 2023-12-01T18:46:39-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 366ab31f by Owen Shepherd at 2023-12-01T18:46:39-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - 427b485b by Owen Shepherd at 2023-12-01T18:46:39-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - d324f2fa by Owen Shepherd at 2023-12-01T18:46:39-05:00 fix: Add missing property of List.group - - - - - be651776 by Matthew Pickering at 2023-12-01T18:46:40-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. - - - - - 0f21b710 by Matthew Pickering at 2023-12-01T18:46:40-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 - - - - - f2981fcc by Matthew Pickering at 2023-12-01T18:46:40-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5504f77c7fe3633190c045e4816d9afc13e4882d...f2981fccd5fd7b3ea56b1a002739da4a3e3bc38f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5504f77c7fe3633190c045e4816d9afc13e4882d...f2981fccd5fd7b3ea56b1a002739da4a3e3bc38f 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 Dec 2 04:47:15 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 01 Dec 2023 23:47:15 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656ab6d35341b_319fc1e4ba830925bc@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7835edda by Owen Shepherd at 2023-12-01T23:47:07-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - c59069c6 by Owen Shepherd at 2023-12-01T23:47:07-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - a880742b by Owen Shepherd at 2023-12-01T23:47:07-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 489d8c87 by Owen Shepherd at 2023-12-01T23:47:07-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - c7e1f309 by Owen Shepherd at 2023-12-01T23:47:07-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - 3cf47808 by Owen Shepherd at 2023-12-01T23:47:07-05:00 fix: Add missing property of List.group - - - - - be08722f by Matthew Pickering at 2023-12-01T23:47:08-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. - - - - - b5d86124 by Matthew Pickering at 2023-12-01T23:47:08-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 - - - - - cf03397c by Matthew Pickering at 2023-12-01T23:47:08-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2981fccd5fd7b3ea56b1a002739da4a3e3bc38f...cf03397ce7417112ae3eeaaf1c012f2e9a06dcfc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f2981fccd5fd7b3ea56b1a002739da4a3e3bc38f...cf03397ce7417112ae3eeaaf1c012f2e9a06dcfc 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 Dec 2 09:08:03 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 02 Dec 2023 04:08:03 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656af3f3a6c1d_319fc114eb083411157c@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 8f1d71c1 by Owen Shepherd at 2023-12-02T04:07:56-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 9ab4cefe by Owen Shepherd at 2023-12-02T04:07:56-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 030c084e by Owen Shepherd at 2023-12-02T04:07:56-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 8d902bf3 by Owen Shepherd at 2023-12-02T04:07:56-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - 70615a7b by Owen Shepherd at 2023-12-02T04:07:56-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - f4d24a1a by Owen Shepherd at 2023-12-02T04:07:56-05:00 fix: Add missing property of List.group - - - - - 529f9322 by Matthew Pickering at 2023-12-02T04:07:57-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. - - - - - c1d0f172 by Matthew Pickering at 2023-12-02T04:07:57-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 - - - - - 96ad77eb by Matthew Pickering at 2023-12-02T04:07:57-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf03397ce7417112ae3eeaaf1c012f2e9a06dcfc...96ad77eb733dbfffbf8ed3cc0e066e5914f69014 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf03397ce7417112ae3eeaaf1c012f2e9a06dcfc...96ad77eb733dbfffbf8ed3cc0e066e5914f69014 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 Dec 2 13:48:31 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 02 Dec 2023 08:48:31 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656b35afa7eae_319fc11b7429ec135290@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 58dd79ad by Owen Shepherd at 2023-12-02T08:48:18-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 1f7b43b0 by Owen Shepherd at 2023-12-02T08:48:18-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - e9a0d92b by Owen Shepherd at 2023-12-02T08:48:18-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 6504d9b5 by Owen Shepherd at 2023-12-02T08:48:18-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - 765465f7 by Owen Shepherd at 2023-12-02T08:48:18-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - 488d7b2c by Owen Shepherd at 2023-12-02T08:48:18-05:00 fix: Add missing property of List.group - - - - - a0ef30ce by Matthew Pickering at 2023-12-02T08:48:19-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. - - - - - 96bd61b0 by Matthew Pickering at 2023-12-02T08:48:19-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 - - - - - 3e20f938 by Matthew Pickering at 2023-12-02T08:48:19-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96ad77eb733dbfffbf8ed3cc0e066e5914f69014...3e20f9383ed1cac3f8ccd4869164e765ab8fb4fb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/96ad77eb733dbfffbf8ed3cc0e066e5914f69014...3e20f9383ed1cac3f8ccd4869164e765ab8fb4fb 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 Dec 2 16:43:30 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Sat, 02 Dec 2023 11:43:30 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Fix wrong fcvt widths Message-ID: <656b5eb247062_319fc11f6e1ddc146921@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 880f6f1c by Sven Tennie at 2023-12-02T12:49:43+01:00 Fix wrong fcvt widths - - - - - 1 changed file: - compiler/GHC/CmmToAsm/RV64/Ppr.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -690,8 +690,8 @@ pprInstr platform instr = case instr of line (pprOp platform o1 <> text "->" <> pprOp platform o2) SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2 - SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.w") o1 o2 - SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.l") o1 o2 + SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2 + SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2 SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2 SCVTF o1 o2 -> pprPanic "RV64.pprInstr - impossible integer to float conversion" $ line (pprOp platform o1 <> text "->" <> pprOp platform o2) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/880f6f1cfa2a93a791487526c6eacca67f223260 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/880f6f1cfa2a93a791487526c6eacca67f223260 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 Dec 2 17:39:21 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 02 Dec 2023 12:39:21 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656b6bc9af3ea_319fc120e13c9415459a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f43a86f6 by Owen Shepherd at 2023-12-02T12:39:07-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 294ef771 by Owen Shepherd at 2023-12-02T12:39:07-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 4852a997 by Owen Shepherd at 2023-12-02T12:39:07-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - fbc2c49f by Owen Shepherd at 2023-12-02T12:39:08-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - 6407d04c by Owen Shepherd at 2023-12-02T12:39:08-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - f42f3016 by Owen Shepherd at 2023-12-02T12:39:08-05:00 fix: Add missing property of List.group - - - - - 94029539 by Matthew Pickering at 2023-12-02T12:39:08-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. - - - - - 12edd0de by Matthew Pickering at 2023-12-02T12:39:08-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 - - - - - cfc1f743 by Matthew Pickering at 2023-12-02T12:39:08-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e20f9383ed1cac3f8ccd4869164e765ab8fb4fb...cfc1f74372a253f67124c27ca2d65605e39722fd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3e20f9383ed1cac3f8ccd4869164e765ab8fb4fb...cfc1f74372a253f67124c27ca2d65605e39722fd 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 Dec 2 21:39:45 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 02 Dec 2023 16:39:45 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656ba4213e90_319fc12658a52c17618c@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: c78c09d2 by Owen Shepherd at 2023-12-02T16:39:30-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 41f978e4 by Owen Shepherd at 2023-12-02T16:39:30-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 2a6d6830 by Owen Shepherd at 2023-12-02T16:39:30-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 346efb15 by Owen Shepherd at 2023-12-02T16:39:31-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - defd677b by Owen Shepherd at 2023-12-02T16:39:31-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - 8c3b9b4f by Owen Shepherd at 2023-12-02T16:39:31-05:00 fix: Add missing property of List.group - - - - - 2cbe5caa by Matthew Pickering at 2023-12-02T16:39:31-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. - - - - - 53005d6d by Matthew Pickering at 2023-12-02T16:39:31-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 - - - - - 6903c728 by Matthew Pickering at 2023-12-02T16:39:31-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cfc1f74372a253f67124c27ca2d65605e39722fd...6903c7280c3e0a87f890a9d3d9e28769e8df5170 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cfc1f74372a253f67124c27ca2d65605e39722fd...6903c7280c3e0a87f890a9d3d9e28769e8df5170 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 Dec 3 00:31:18 2023 From: gitlab at gitlab.haskell.org (Hassan Al-Awwadi (@hassan.awwadi)) Date: Sat, 02 Dec 2023 19:31:18 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24040-ghci-timeout Message-ID: <656bcc56b4632_319fc12aa289f41930d3@gitlab.mail> Hassan Al-Awwadi pushed new branch wip/T24040-ghci-timeout at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24040-ghci-timeout 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 Dec 3 01:00:03 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 02 Dec 2023 20:00:03 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656bd31398fa4_319fc12b45673c1959ad@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e9d23761 by Owen Shepherd at 2023-12-02T19:59:55-05:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 2a5eb900 by Owen Shepherd at 2023-12-02T19:59:55-05:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - f95afdcf by Owen Shepherd at 2023-12-02T19:59:56-05:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 45fd9f51 by Owen Shepherd at 2023-12-02T19:59:56-05:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - 6f5ce0c3 by Owen Shepherd at 2023-12-02T19:59:56-05:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - a56cc5b8 by Owen Shepherd at 2023-12-02T19:59:56-05:00 fix: Add missing property of List.group - - - - - 54d4d90d by Matthew Pickering at 2023-12-02T19:59:56-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. - - - - - d1b88882 by Matthew Pickering at 2023-12-02T19:59:56-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 - - - - - 91d1a7dd by Matthew Pickering at 2023-12-02T19:59:56-05:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 7 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6903c7280c3e0a87f890a9d3d9e28769e8df5170...91d1a7dde6aeac3bf022341205cc08de4ce6cfe9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6903c7280c3e0a87f890a9d3d9e28769e8df5170...91d1a7dde6aeac3bf022341205cc08de4ce6cfe9 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 Dec 3 05:10:44 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sun, 03 Dec 2023 00:10:44 -0500 Subject: [Git][ghc/ghc][master] 6 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <656c0dd484a4e_319fc1310fbc6c208341@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 2 changed files: - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs Changes: ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd8acc0c6a90971f9d70eda9bc7204470bfb49f7...cad3b734ab9fe2e45505de7f13f676aeb539d6d8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bd8acc0c6a90971f9d70eda9bc7204470bfb49f7...cad3b734ab9fe2e45505de7f13f676aeb539d6d8 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 Dec 3 05:11:29 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sun, 03 Dec 2023 00:11:29 -0500 Subject: [Git][ghc/ghc][master] testsuite: Fix T21097b test with make 4.1 (deb9) Message-ID: <656c0e019d0fa_319fc1317d27842113dc@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 2 changed files: - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T Changes: ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bad3765668cc5badf5d0a19100fac95125985473 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bad3765668cc5badf5d0a19100fac95125985473 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 Dec 3 05:12:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sun, 03 Dec 2023 00:12:13 -0500 Subject: [Git][ghc/ghc][master] 2 commits: testsuite: Track size of libdir in bytes Message-ID: <656c0e2d4ede6_319fc1314f2ec42145a4@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 3 changed files: - testsuite/driver/testlib.py - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bad3765668cc5badf5d0a19100fac95125985473...f5eb0f2982e9cf27515e892c4bdf634bcfb28459 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bad3765668cc5badf5d0a19100fac95125985473...f5eb0f2982e9cf27515e892c4bdf634bcfb28459 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 Dec 3 10:38:04 2023 From: gitlab at gitlab.haskell.org (Hassan Al-Awwadi (@hassan.awwadi)) Date: Sun, 03 Dec 2023 05:38:04 -0500 Subject: [Git][ghc/ghc][wip/T24040-ghci-timeout] 8 commits: distrib: Rediscover otool and install_name_tool on Darwin Message-ID: <656c5a8cc81b1_319fc1398c57742161bc@gitlab.mail> Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 71cde983 by Hassan Al-Awwadi at 2023-12-03T11:36:16+01:00 Merge branch 'master' into wip/T24040-ghci-timeout - - - - - 28 changed files: - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - distrib/configure.ac.in - testsuite/tests/dependent/should_fail/T16326_Fail12.stderr - testsuite/tests/perf/compiler/T12545.hs - testsuite/tests/perf/compiler/T13386.hs - testsuite/tests/perf/compiler/T8095.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/perf/size/all.T - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/vdq-rta/should_fail/T24176.hs - + testsuite/tests/vdq-rta/should_fail/T24176.stderr - testsuite/tests/vdq-rta/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Types.hs - utils/check-exact/Utils.hs - utils/haddock Changes: ===================================== 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 ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Parser.Annotation ( -- * In-tree Exact Print Annotations AddEpAnn(..), - EpaLocation(..), epaLocationRealSrcSpan, + EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan, TokenLocation(..), getTokenSrcSpan, DeltaPos(..), deltaPos, getDeltaLine, @@ -26,7 +26,8 @@ module GHC.Parser.Annotation ( -- ** Comments in Annotations - EpAnnComments(..), LEpaComment, emptyComments, + EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments, + epaToNoCommentsLocation, noCommentsToEpaLocation, getFollowingComments, setFollowingComments, setPriorComments, EpAnnCO, @@ -402,9 +403,26 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- in the @'EpaDelta'@ variant captures any comments between the prior -- output and the thing being marked here, since we cannot otherwise -- sort the relative order. -data EpaLocation = EpaSpan !SrcSpan - | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq,Show) + +data EpaLocation' a = EpaSpan !SrcSpan + | EpaDelta !DeltaPos !a + deriving (Data,Eq,Show) + +type EpaLocation = EpaLocation' [LEpaComment] + +type NoCommentsLocation = EpaLocation' NoComments + +data NoComments = NoComments + deriving (Data,Eq,Ord,Show) + +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation +epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss +epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments +epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation" + +noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation +noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss +noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp [] -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). @@ -454,7 +472,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" -instance Outputable EpaLocation where +instance Outputable NoComments where + ppr NoComments = text "NoComments" + +instance (Outputable a) => Outputable (EpaLocation' a) where ppr (EpaSpan r) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs @@ -517,18 +538,18 @@ data EpAnn ann -- that relationship is tracked in the 'anchor_op' instead. type Anchor = EpaLocation -- Transitional -anchor :: Anchor -> RealSrcSpan +anchor :: (EpaLocation' a) -> RealSrcSpan anchor (EpaSpan (RealSrcSpan r _)) = r anchor _ = panic "anchor" -spanAsAnchor :: SrcSpan -> Anchor +spanAsAnchor :: SrcSpan -> (EpaLocation' a) spanAsAnchor ss = EpaSpan ss -realSpanAsAnchor :: RealSrcSpan -> Anchor +realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a) realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) -noSpanAnchor :: Anchor -noSpanAnchor = EpaDelta (SameLine 0) [] +noSpanAnchor :: (NoAnn a) => (EpaLocation' a) +noSpanAnchor = EpaDelta (SameLine 0) noAnn -- --------------------------------------------------------------------- @@ -546,7 +567,7 @@ data EpAnnComments = EpaComments , followingComments :: ![LEpaComment] } deriving (Data, Eq) -type LEpaComment = GenLocated Anchor EpaComment +type LEpaComment = GenLocated NoCommentsLocation EpaComment emptyComments :: EpAnnComments emptyComments = EpaComments [] @@ -1333,7 +1354,7 @@ instance Outputable DeltaPos where ppr (SameLine c) = text "SameLine" <+> ppr c ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c -instance Outputable (GenLocated Anchor EpaComment) where +instance Outputable (GenLocated NoCommentsLocation EpaComment) where ppr (L l c) = text "L" <+> ppr l <+> ppr c instance Outputable EpAnnComments where ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -459,7 +459,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) rnBindLHS name_maker _ (PatSynBind x psb at PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker - = do { addLocMA checkConName rdrname + = do { addLocM checkConName rdrname ; name <- lookupLocatedTopConstructorRnN rdrname -- Should be in scope already ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -276,7 +276,7 @@ rnSrcWarnDecls bndr_set decls' ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) warn_rdr_dups - ; pairs_s <- mapM (addLocMA rn_deprec) decls + ; pairs_s <- mapM (addLocM rn_deprec) decls ; return $ concat pairs_s } where decls = concatMap (wd_warnings . unLoc) decls' @@ -1891,7 +1891,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData ; unless (null (fromMaybeContext context)) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts - ; mapM_ (addLocMA check_type_data_condecl) condecls + ; mapM_ (addLocM check_type_data_condecl) condecls ; unless (null derivs) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses } @@ -2384,7 +2384,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args , con_doc = mb_doc, con_forall = forall_ }) - = do { _ <- addLocMA checkConName name + = do { _ <- addLocM checkConName name ; new_name <- lookupLocatedTopConstructorRnN name -- We bind no implicit binders here; this is just like @@ -2421,7 +2421,7 @@ rnConDecl (ConDeclGADT { con_names = names , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) - = do { mapM_ (addLocMA checkConName) names + = do { mapM_ (addLocM checkConName) names ; new_names <- mapM (lookupLocatedTopConstructorRnN) names ; let -- We must ensure that we extract the free tkvs in left-to-right ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -223,7 +223,7 @@ tcCompleteSigs sigs = -- compatible with the result type constructor 'mb_tc'. doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm)) = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns + cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc } doOne _ = return Nothing @@ -239,7 +239,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] tcHsBootSigs binds sigs = do { unless (null binds) $ rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds) - ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1178,17 +1178,30 @@ tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls -tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind - = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ - tc_lhs_type mode ty exp_kind +tc_hs_type mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + | HsForAllInvis{} <- tele + = tc_hs_forall_ty tele ty exp_kind + -- For an invisible forall, we allow the body to have + -- an arbitrary kind (hence exp_kind above). + -- See Note [Body kind of a HsForAllTy] + + | HsForAllVis{} <- tele + = do { ek <- newOpenTypeKind + ; r <- tc_hs_forall_ty tele ty ek + ; checkExpectedKind t r ek exp_kind } + -- For a visible forall, we require that the body is of kind TYPE r. + -- See Note [Body kind of a HsForAllTy] + + where + tc_hs_forall_ty tele ty ek + = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ + tc_lhs_type mode ty ek -- Pass on the mode from the type, to any wildcards -- in kind signatures on the forall'd variables -- e.g. f :: _ -> Int -> forall (a :: _). blah - -- Why exp_kind? See Note [Body kind of a HsForAllTy] - -- Do not kind-generalise here! See Note [Kind generalisation] - - ; return (mkForAllTys tv_bndrs ty') } + -- Do not kind-generalise here! See Note [Kind generalisation] + ; return (mkForAllTys tv_bndrs ty') } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt) @@ -2042,25 +2055,23 @@ examples. Note [Body kind of a HsForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see +The body of a forall is usually a type. +Because of representation polymorphism, it can be a TYPE r, for any r. +(In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all via CPR analysis; see typecheck/should_compile/tc170). -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is (TYPE _). But this is -wrong. For example: +A forall can also be used in an instance head, then the body should +be a constraint. - class C a b - newtype N = Mk Foo deriving (C a) +Right now, we do not have any easy way to enforce that a type is +either a TYPE something or CONSTRAINT something, so we accept any kind. +This is unsound (#22063). We could fix this by implementing a TypeLike +predicate, see #20000. -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for (TYPE _) here. +For a forall with a required argument, we do not allow constraints; +e.g. forall a -> Eq a is invalid. Therefore, we can enforce that the body +is a TYPE something in this case (#24176). Note [Body kind of a HsQualTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -1516,7 +1516,7 @@ inferInitialKinds decls ; traceTc "inferInitialKinds done }" empty ; return tcs } where - infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. @@ -1528,7 +1528,7 @@ checkInitialKinds decls ; return tcs } where check_initial_kind (ldecl, msig) = - addLocMA (getInitialKind (InitialKindCheck msig)) ldecl + addLocM (getInitialKind (InitialKindCheck msig)) ldecl -- | Get the initial kind of a TyClDecl, either generalized or non-generalized, -- depending on the 'InitialKindStrategy'. @@ -1556,7 +1556,7 @@ getInitialKind strategy -- See Note [Don't process associated types in getInitialKind] ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ - mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats + mapM (addLocM (getAssocFamInitialKind cls_tc)) ats ; return (cls_tc : at_tcs) } where getAssocFamInitialKind cls = @@ -2621,7 +2621,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs -- The (binderVars tc_bndrs) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocMA tc_fundep) fundeps + ; fds <- mapM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } @@ -2724,7 +2724,7 @@ tcClassATs class_name cls ats at_defs (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at + tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] @@ -3579,7 +3579,7 @@ tcConDecls :: DataDeclInfo -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) tcConDecls dd_info rep_tycon tmpl_bndrs res_kind = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> - addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) + addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -237,7 +237,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocMA (badDmPrag sel_id )) + mapM_ (addLocM (badDmPrag sel_id )) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2425,7 +2425,7 @@ Note that tcSpecInstPrags :: DFunId -> InstBindings GhcRn -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $ + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragEnv uprags binds) } ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -218,7 +218,7 @@ span of the Name. tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name - = addLocMA tcLookupGlobal name + = addLocM tcLookupGlobal name tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always @@ -308,13 +308,13 @@ tcLookupAxiom name = do _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id -tcLookupLocatedGlobalId = addLocMA tcLookupId +tcLookupLocatedGlobalId = addLocM tcLookupId tcLookupLocatedClass :: LocatedA Name -> TcM Class -tcLookupLocatedClass = addLocMA tcLookupClass +tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon -tcLookupLocatedTyCon = addLocMA tcLookupTyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts). @@ -440,7 +440,7 @@ tcExtendRecEnv gbl_stuff thing_inside -} tcLookupLocated :: LocatedA Name -> TcM TcTyThing -tcLookupLocated = addLocMA tcLookup +tcLookupLocated = addLocM tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -61,9 +61,9 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, - wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, @@ -995,18 +995,15 @@ setInGeneratedCode thing_inside = setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a +addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b +addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a -addLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcM b -addLocMA fn (L loc a) = setSrcSpanA loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (L loc b) } - -wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b) -wrapLocAM fn a = wrapLocM fn (reLoc a) +wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b) +wrapLocM fn (L loc a) = + let + loc' = getHasLoc loc + in setSrcSpan loc' $ do { b <- fn a + ; return (L loc' b) } wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a ===================================== distrib/configure.ac.in ===================================== @@ -206,6 +206,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) + # Check that we have the same emsdk version as the one we were built with. ConfiguredEmsdkVersion=@ConfiguredEmsdkVersion@ EMSDK_VERSION("", "", ${ConfiguredEmsdkVersion}) ===================================== testsuite/tests/dependent/should_fail/T16326_Fail12.stderr ===================================== @@ -1,8 +1,8 @@ -T16326_Fail12.hs:6:1: error: [GHC-51580] - • Illegal visible, dependent quantification in the type of a term: - forall a -> Show a - • In the context: forall a -> Show a - While checking the super-classes of class ‘C’ - In the class declaration for ‘C’ - Suggested fix: Perhaps you intended to use RequiredTypeArguments +T16326_Fail12.hs:6:8: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Show a’ is a type + • In the class declaration for ‘C’ + +T16326_Fail12.hs:6:20: error: [GHC-83865] + • Expected a type, but ‘Show a’ is a constraint + • In the class declaration for ‘C’ ===================================== testsuite/tests/perf/compiler/T12545.hs ===================================== @@ -15,6 +15,29 @@ type instance ElemsOf A = [ T1, T2, T3, T4, T5, T6, T7, T8 , T25, T26, T27, T28, T29, T30, T31, T32 ] +{- Note [Sensitivity to unique increment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T12545 is sensitive to -dunique-increments changes, see #19414. I've seen +variations of as much as 4.8% by playing with that parameter. + +The issue with this test is that it does too little so is very sensitive to +any small variations during initialisation and in particular populating the +initial environments with wired-in things. Therefore it has a very high change +threshold so we catch if it regresses a lot but don't worry if it regresses a little. + +You can measure the variance by running T12545.measure.sh. + +Whenever we identify such a test (T8095 being another example), we leave a link +to this Note in the source code of the test *and* in the corresponding all.T, +detailing the spread as measured by adjusting T12545.measure.sh. +For example, + +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% + +and then double the spread to come up with a stable acceptance threshold (e.g., +10%). +-} + data T1; instance ElemOf A T1 where data T2; instance ElemOf A T2 where data T3; instance ElemOf A T3 where ===================================== testsuite/tests/perf/compiler/T13386.hs ===================================== @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -O0 -freduction-depth=500 #-} - +-- Subject to Note [Sensitivity to unique increment] with spread of 1.5% module T13386 where import GHC.TypeLits ===================================== testsuite/tests/perf/compiler/T8095.hs ===================================== @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -freduction-depth=1000 #-} {-# LANGUAGE TypeOperators,DataKinds,KindSignatures,TypeFamilies,PolyKinds,UndecidableInstances #-} +-- Subject to Note [Sensitivity to unique increment] with spread of 1.7% import GHC.TypeLits data Nat1 = Zero | Succ Nat1 type family Replicate1 (n :: Nat1) (x::a) :: [a] @@ -16,4 +17,3 @@ instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ f X = Y f Y = X test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) () )) - ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -167,14 +167,18 @@ test('T9872d', ], compile, ['']) +# Since major improvements to T8095 in in +# 4bf9fa0f216bb294c1bd3644363b008a8643a653 it is subject to +# Note [Sensitivity to unique increment] in T12545.hs; spread was 1.7% test ('T8095', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',2) ], + collect_compiler_stats('bytes allocated',4) ], compile, ['-v0 -O']) +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 1.5% test ('T13386', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',1) ], + collect_compiler_stats('bytes allocated',3) ], compile, ['-v0 -O0']) @@ -261,15 +265,7 @@ test('T12234', compile, ['']) -# T12545 is sensitive to -dunique-increments changes, see #19414. I've seen -# variations of as much as 4.8% by playing with that parameter, -# -# The issue with the test is that it does too little so is very sensitive to -# any small variations during initialisation and in particular populating the -# initial environments with wired-in things. Therefore it has a very high change -# threshold so we catch if it regresses a lot but don't worry if it regresses a little. -# -# You can measure the variance by running T12545.measure.sh. +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% test('T12545', [ only_ways(['normal']), collect_compiler_stats('bytes allocated', 10), # ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ -test('size_hello_obj', [collect_size(3, 'size_hello_obj.o')], compile, ['']) +test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 3, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -17,7 +17,8 @@ { Test20297.hs:11:22-26 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.hs:1:1-33 }) + (EpaSpan + { Test20297.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") @@ -114,7 +115,8 @@ (AddEpAnn AnnEqual (EpaSpan { Test20297.hs:5:5 }))) (EpaComments [(L - (EpaSpan { Test20297.hs:6:3-13 }) + (EpaSpan + { Test20297.hs:6:3-13 }) (EpaComment (EpaLineComment "-- comment0") @@ -162,7 +164,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:7:9-19 }) + (EpaSpan + { Test20297.hs:7:9-19 }) (EpaComment (EpaLineComment "-- comment1") @@ -267,7 +270,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:10:9-19 }) + (EpaSpan + { Test20297.hs:10:9-19 }) (EpaComment (EpaLineComment "-- comment2") @@ -436,7 +440,8 @@ { Test20297.ppr.hs:9:20-24 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.ppr.hs:1:1-33 }) + (EpaSpan + { Test20297.ppr.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") ===================================== testsuite/tests/vdq-rta/should_fail/T24176.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE QuantifiedConstraints, RequiredTypeArguments #-} +module T24176 where + +f :: (forall a -> Eq a) => a +f = f ===================================== testsuite/tests/vdq-rta/should_fail/T24176.stderr ===================================== @@ -0,0 +1,8 @@ + +T24176.hs:4:7: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Eq a’ is a type + • In the type signature: f :: (forall a -> Eq a) => a + +T24176.hs:4:19: error: [GHC-83865] + • Expected a type, but ‘Eq a’ is a constraint + • In the type signature: f :: (forall a -> Eq a) => a ===================================== testsuite/tests/vdq-rta/should_fail/all.T ===================================== @@ -14,4 +14,5 @@ test('T22326_fail_patsyn', normal, compile_fail, ['']) test('T22326_fail_match', normal, compile_fail, ['']) test('T23738_fail_wild', normal, compile_fail, ['']) test('T23738_fail_implicit_tv', normal, compile_fail, ['']) -test('T23738_fail_var', normal, compile_fail, ['']) \ No newline at end of file +test('T23738_fail_var', normal, compile_fail, ['']) +test('T24176', normal, compile_fail, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -619,7 +619,7 @@ annotationsToComments (EpAnn anc a cs) l kws = do go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) go acc [] = acc go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls + | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls | otherwise = go (cs', (AddEpAnn k ss):ans) ls -- --------------------------------------------------------------------- @@ -677,7 +677,7 @@ printStringAtRsC capture pa str = do NoCaptureComments -> return [] debugM $ "printStringAtRsC:cs'=" ++ show cs' debugM $ "printStringAtRsC:p'=" ++ showAst p' - debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments) debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) return (EpaDelta p' (map comment2LEpaComment cs')) @@ -1365,14 +1365,14 @@ printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsBefore ss = do cs <- commentAllocationBefore ss debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsIn ss = do cs <- commentAllocationIn ss debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs debugM $ "printCommentsIn:done" @@ -1423,12 +1423,12 @@ updateAndApplyComment (Comment str anc pp mo) dp = do _ -> dp'' op' = case dp' of SameLine n -> if n >= 0 - then EpaDelta dp' [] - else EpaDelta dp [] - _ -> EpaDelta dp' [] - anc' = if str == "" && op' == EpaDelta (SameLine 0) [] -- EOF comment - then EpaDelta dp [] - else EpaDelta dp [] + then EpaDelta dp' NoComments + else EpaDelta dp NoComments + _ -> EpaDelta dp' NoComments + anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment + then EpaDelta dp NoComments + else EpaDelta dp NoComments -- --------------------------------------------------------------------- ===================================== utils/check-exact/Main.hs ===================================== @@ -68,6 +68,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6) + -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3) ===================================== utils/check-exact/Transform.hs ===================================== @@ -283,8 +283,9 @@ setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp (dp0,c') = go h in (dp0, c':t, EpaCommentsBalanced [] ts) + go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e) go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c) - go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) + go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c) setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp = case sortEpaComments (priorComments cs) of [] -> @@ -293,7 +294,7 @@ setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp L (EpAnn (EpaDelta edp csd) an cs'') a where cs'' = setPriorComments cs [] - csd = L (EpaDelta dp []) c:cs' + csd = L (EpaDelta dp NoComments) c:cs' lc = last $ (L ca c:cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r ===================================== utils/check-exact/Types.hs ===================================== @@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators - , commentAnchor :: !Anchor + , commentLoc :: !NoCommentsLocation , commentPriorTok :: !RealSrcSpan , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } ===================================== utils/check-exact/Utils.hs ===================================== @@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0 -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) - = (L (EpaDelta dp []) (GHC.EpaComment t pp)) + = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp)) `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp)) where (r,c) = ss2posEnd pp @@ -253,7 +253,7 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s tokComment :: LEpaComment -> [Comment] tokComment t@(L lt c) = case c of - (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc + (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] @@ -268,9 +268,9 @@ hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = in (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs)) hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk)) - = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments anc pt (NestedDocString dec (L _ chunk)) - = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code @@ -301,11 +301,11 @@ mkEpaComments priorCs postCs comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r -mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment -mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r)) +mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment +mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r)) -mkComment :: String -> Anchor -> RealSrcSpan -> Comment -mkComment c anc r = Comment c anc r Nothing +mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment +mkComment c loc r = Comment c loc r Nothing -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String @@ -328,11 +328,11 @@ sortEpaComments cs = sortBy cmp cs cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> EpaLocation -> Comment +mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) mkKWComment kw (EpaSpan (UnhelpfulSpan _)) - = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw) + = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta dp cs) = Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw) @@ -481,7 +481,7 @@ hsDeclsClassDecl dec = case dec of tcdATs = ats, tcdATDefs = at_defs } -> map snd decls where - srs :: (HasLoc a) => a -> RealSrcSpan + srs :: EpAnn a -> RealSrcSpan srs a = realSrcSpan $ locA a decls = orderedDecls sortKey $ Map.fromList ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a +Subproject commit a7eae7da6868b22dc7109142475b228c60509812 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...71cde98358a14621727b0150fe5f7913d25578c1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...71cde98358a14621727b0150fe5f7913d25578c1 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 Dec 3 11:17:58 2023 From: gitlab at gitlab.haskell.org (Hassan Al-Awwadi (@hassan.awwadi)) Date: Sun, 03 Dec 2023 06:17:58 -0500 Subject: [Git][ghc/ghc][wip/T24040-ghci-timeout] Deleted 8 commits: distrib: Rediscover otool and install_name_tool on Darwin Message-ID: <656c63e692210_319fc13a54bf98216789@gitlab.mail> Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: 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 - - - - - 71cde983 by Hassan Al-Awwadi at 2023-12-03T11:36:16+01:00 Merge branch 'master' into wip/T24040-ghci-timeout - - - - - 28 changed files: - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - distrib/configure.ac.in - testsuite/tests/dependent/should_fail/T16326_Fail12.stderr - testsuite/tests/perf/compiler/T12545.hs - testsuite/tests/perf/compiler/T13386.hs - testsuite/tests/perf/compiler/T8095.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/perf/size/all.T - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/vdq-rta/should_fail/T24176.hs - + testsuite/tests/vdq-rta/should_fail/T24176.stderr - testsuite/tests/vdq-rta/should_fail/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Types.hs - utils/check-exact/Utils.hs - utils/haddock Changes: ===================================== 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 ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -13,7 +13,7 @@ module GHC.Parser.Annotation ( -- * In-tree Exact Print Annotations AddEpAnn(..), - EpaLocation(..), epaLocationRealSrcSpan, + EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan, TokenLocation(..), getTokenSrcSpan, DeltaPos(..), deltaPos, getDeltaLine, @@ -26,7 +26,8 @@ module GHC.Parser.Annotation ( -- ** Comments in Annotations - EpAnnComments(..), LEpaComment, emptyComments, + EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments, + epaToNoCommentsLocation, noCommentsToEpaLocation, getFollowingComments, setFollowingComments, setPriorComments, EpAnnCO, @@ -402,9 +403,26 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- in the @'EpaDelta'@ variant captures any comments between the prior -- output and the thing being marked here, since we cannot otherwise -- sort the relative order. -data EpaLocation = EpaSpan !SrcSpan - | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq,Show) + +data EpaLocation' a = EpaSpan !SrcSpan + | EpaDelta !DeltaPos !a + deriving (Data,Eq,Show) + +type EpaLocation = EpaLocation' [LEpaComment] + +type NoCommentsLocation = EpaLocation' NoComments + +data NoComments = NoComments + deriving (Data,Eq,Ord,Show) + +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation +epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss +epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments +epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation" + +noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation +noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss +noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp [] -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). @@ -454,7 +472,10 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" -instance Outputable EpaLocation where +instance Outputable NoComments where + ppr NoComments = text "NoComments" + +instance (Outputable a) => Outputable (EpaLocation' a) where ppr (EpaSpan r) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs @@ -517,18 +538,18 @@ data EpAnn ann -- that relationship is tracked in the 'anchor_op' instead. type Anchor = EpaLocation -- Transitional -anchor :: Anchor -> RealSrcSpan +anchor :: (EpaLocation' a) -> RealSrcSpan anchor (EpaSpan (RealSrcSpan r _)) = r anchor _ = panic "anchor" -spanAsAnchor :: SrcSpan -> Anchor +spanAsAnchor :: SrcSpan -> (EpaLocation' a) spanAsAnchor ss = EpaSpan ss -realSpanAsAnchor :: RealSrcSpan -> Anchor +realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a) realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) -noSpanAnchor :: Anchor -noSpanAnchor = EpaDelta (SameLine 0) [] +noSpanAnchor :: (NoAnn a) => (EpaLocation' a) +noSpanAnchor = EpaDelta (SameLine 0) noAnn -- --------------------------------------------------------------------- @@ -546,7 +567,7 @@ data EpAnnComments = EpaComments , followingComments :: ![LEpaComment] } deriving (Data, Eq) -type LEpaComment = GenLocated Anchor EpaComment +type LEpaComment = GenLocated NoCommentsLocation EpaComment emptyComments :: EpAnnComments emptyComments = EpaComments [] @@ -1333,7 +1354,7 @@ instance Outputable DeltaPos where ppr (SameLine c) = text "SameLine" <+> ppr c ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c -instance Outputable (GenLocated Anchor EpaComment) where +instance Outputable (GenLocated NoCommentsLocation EpaComment) where ppr (L l c) = text "L" <+> ppr l <+> ppr c instance Outputable EpAnnComments where ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -459,7 +459,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) rnBindLHS name_maker _ (PatSynBind x psb at PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker - = do { addLocMA checkConName rdrname + = do { addLocM checkConName rdrname ; name <- lookupLocatedTopConstructorRnN rdrname -- Should be in scope already ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -276,7 +276,7 @@ rnSrcWarnDecls bndr_set decls' ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) warn_rdr_dups - ; pairs_s <- mapM (addLocMA rn_deprec) decls + ; pairs_s <- mapM (addLocM rn_deprec) decls ; return $ concat pairs_s } where decls = concatMap (wd_warnings . unLoc) decls' @@ -1891,7 +1891,7 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData ; unless (null (fromMaybeContext context)) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts - ; mapM_ (addLocMA check_type_data_condecl) condecls + ; mapM_ (addLocM check_type_data_condecl) condecls ; unless (null derivs) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses } @@ -2384,7 +2384,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args , con_doc = mb_doc, con_forall = forall_ }) - = do { _ <- addLocMA checkConName name + = do { _ <- addLocM checkConName name ; new_name <- lookupLocatedTopConstructorRnN name -- We bind no implicit binders here; this is just like @@ -2421,7 +2421,7 @@ rnConDecl (ConDeclGADT { con_names = names , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) - = do { mapM_ (addLocMA checkConName) names + = do { mapM_ (addLocM checkConName) names ; new_names <- mapM (lookupLocatedTopConstructorRnN) names ; let -- We must ensure that we extract the free tkvs in left-to-right ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -223,7 +223,7 @@ tcCompleteSigs sigs = -- compatible with the result type constructor 'mb_tc'. doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm)) = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns + cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc } doOne _ = return Nothing @@ -239,7 +239,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] tcHsBootSigs binds sigs = do { unless (null binds) $ rejectBootDecls HsBoot BootBindsRn (concatMap (bagToList . snd) binds) - ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1178,17 +1178,30 @@ tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls -tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind - = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ - tc_lhs_type mode ty exp_kind +tc_hs_type mode t@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + | HsForAllInvis{} <- tele + = tc_hs_forall_ty tele ty exp_kind + -- For an invisible forall, we allow the body to have + -- an arbitrary kind (hence exp_kind above). + -- See Note [Body kind of a HsForAllTy] + + | HsForAllVis{} <- tele + = do { ek <- newOpenTypeKind + ; r <- tc_hs_forall_ty tele ty ek + ; checkExpectedKind t r ek exp_kind } + -- For a visible forall, we require that the body is of kind TYPE r. + -- See Note [Body kind of a HsForAllTy] + + where + tc_hs_forall_ty tele ty ek + = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ + tc_lhs_type mode ty ek -- Pass on the mode from the type, to any wildcards -- in kind signatures on the forall'd variables -- e.g. f :: _ -> Int -> forall (a :: _). blah - -- Why exp_kind? See Note [Body kind of a HsForAllTy] - -- Do not kind-generalise here! See Note [Kind generalisation] - - ; return (mkForAllTys tv_bndrs ty') } + -- Do not kind-generalise here! See Note [Kind generalisation] + ; return (mkForAllTys tv_bndrs ty') } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt) @@ -2042,25 +2055,23 @@ examples. Note [Body kind of a HsForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see +The body of a forall is usually a type. +Because of representation polymorphism, it can be a TYPE r, for any r. +(In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all via CPR analysis; see typecheck/should_compile/tc170). -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is (TYPE _). But this is -wrong. For example: +A forall can also be used in an instance head, then the body should +be a constraint. - class C a b - newtype N = Mk Foo deriving (C a) +Right now, we do not have any easy way to enforce that a type is +either a TYPE something or CONSTRAINT something, so we accept any kind. +This is unsound (#22063). We could fix this by implementing a TypeLike +predicate, see #20000. -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for (TYPE _) here. +For a forall with a required argument, we do not allow constraints; +e.g. forall a -> Eq a is invalid. Therefore, we can enforce that the body +is a TYPE something in this case (#24176). Note [Body kind of a HsQualTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -1516,7 +1516,7 @@ inferInitialKinds decls ; traceTc "inferInitialKinds done }" empty ; return tcs } where - infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. @@ -1528,7 +1528,7 @@ checkInitialKinds decls ; return tcs } where check_initial_kind (ldecl, msig) = - addLocMA (getInitialKind (InitialKindCheck msig)) ldecl + addLocM (getInitialKind (InitialKindCheck msig)) ldecl -- | Get the initial kind of a TyClDecl, either generalized or non-generalized, -- depending on the 'InitialKindStrategy'. @@ -1556,7 +1556,7 @@ getInitialKind strategy -- See Note [Don't process associated types in getInitialKind] ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ - mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats + mapM (addLocM (getAssocFamInitialKind cls_tc)) ats ; return (cls_tc : at_tcs) } where getAssocFamInitialKind cls = @@ -2621,7 +2621,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs -- The (binderVars tc_bndrs) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocMA tc_fundep) fundeps + ; fds <- mapM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } @@ -2724,7 +2724,7 @@ tcClassATs class_name cls ats at_defs (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at + tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] @@ -3579,7 +3579,7 @@ tcConDecls :: DataDeclInfo -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) tcConDecls dd_info rep_tycon tmpl_bndrs res_kind = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> - addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) + addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -237,7 +237,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocMA (badDmPrag sel_id )) + mapM_ (addLocM (badDmPrag sel_id )) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2425,7 +2425,7 @@ Note that tcSpecInstPrags :: DFunId -> InstBindings GhcRn -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $ + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragEnv uprags binds) } ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -218,7 +218,7 @@ span of the Name. tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name - = addLocMA tcLookupGlobal name + = addLocM tcLookupGlobal name tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always @@ -308,13 +308,13 @@ tcLookupAxiom name = do _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id -tcLookupLocatedGlobalId = addLocMA tcLookupId +tcLookupLocatedGlobalId = addLocM tcLookupId tcLookupLocatedClass :: LocatedA Name -> TcM Class -tcLookupLocatedClass = addLocMA tcLookupClass +tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon -tcLookupLocatedTyCon = addLocMA tcLookupTyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts). @@ -440,7 +440,7 @@ tcExtendRecEnv gbl_stuff thing_inside -} tcLookupLocated :: LocatedA Name -> TcM TcTyThing -tcLookupLocated = addLocMA tcLookup +tcLookupLocated = addLocM tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -61,9 +61,9 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, - wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, @@ -995,18 +995,15 @@ setInGeneratedCode thing_inside = setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a +addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b +addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a -addLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcM b -addLocMA fn (L loc a) = setSrcSpanA loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (L loc b) } - -wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b) -wrapLocAM fn a = wrapLocM fn (reLoc a) +wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b) +wrapLocM fn (L loc a) = + let + loc' = getHasLoc loc + in setSrcSpan loc' $ do { b <- fn a + ; return (L loc' b) } wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a ===================================== distrib/configure.ac.in ===================================== @@ -206,6 +206,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) + # Check that we have the same emsdk version as the one we were built with. ConfiguredEmsdkVersion=@ConfiguredEmsdkVersion@ EMSDK_VERSION("", "", ${ConfiguredEmsdkVersion}) ===================================== testsuite/tests/dependent/should_fail/T16326_Fail12.stderr ===================================== @@ -1,8 +1,8 @@ -T16326_Fail12.hs:6:1: error: [GHC-51580] - • Illegal visible, dependent quantification in the type of a term: - forall a -> Show a - • In the context: forall a -> Show a - While checking the super-classes of class ‘C’ - In the class declaration for ‘C’ - Suggested fix: Perhaps you intended to use RequiredTypeArguments +T16326_Fail12.hs:6:8: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Show a’ is a type + • In the class declaration for ‘C’ + +T16326_Fail12.hs:6:20: error: [GHC-83865] + • Expected a type, but ‘Show a’ is a constraint + • In the class declaration for ‘C’ ===================================== testsuite/tests/perf/compiler/T12545.hs ===================================== @@ -15,6 +15,29 @@ type instance ElemsOf A = [ T1, T2, T3, T4, T5, T6, T7, T8 , T25, T26, T27, T28, T29, T30, T31, T32 ] +{- Note [Sensitivity to unique increment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T12545 is sensitive to -dunique-increments changes, see #19414. I've seen +variations of as much as 4.8% by playing with that parameter. + +The issue with this test is that it does too little so is very sensitive to +any small variations during initialisation and in particular populating the +initial environments with wired-in things. Therefore it has a very high change +threshold so we catch if it regresses a lot but don't worry if it regresses a little. + +You can measure the variance by running T12545.measure.sh. + +Whenever we identify such a test (T8095 being another example), we leave a link +to this Note in the source code of the test *and* in the corresponding all.T, +detailing the spread as measured by adjusting T12545.measure.sh. +For example, + +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% + +and then double the spread to come up with a stable acceptance threshold (e.g., +10%). +-} + data T1; instance ElemOf A T1 where data T2; instance ElemOf A T2 where data T3; instance ElemOf A T3 where ===================================== testsuite/tests/perf/compiler/T13386.hs ===================================== @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -O0 -freduction-depth=500 #-} - +-- Subject to Note [Sensitivity to unique increment] with spread of 1.5% module T13386 where import GHC.TypeLits ===================================== testsuite/tests/perf/compiler/T8095.hs ===================================== @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -freduction-depth=1000 #-} {-# LANGUAGE TypeOperators,DataKinds,KindSignatures,TypeFamilies,PolyKinds,UndecidableInstances #-} +-- Subject to Note [Sensitivity to unique increment] with spread of 1.7% import GHC.TypeLits data Nat1 = Zero | Succ Nat1 type family Replicate1 (n :: Nat1) (x::a) :: [a] @@ -16,4 +17,3 @@ instance (xs ~ Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ f X = Y f Y = X test1 = f (X :: Data ( Replicate1 ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Succ ( Zero ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) () )) - ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -167,14 +167,18 @@ test('T9872d', ], compile, ['']) +# Since major improvements to T8095 in in +# 4bf9fa0f216bb294c1bd3644363b008a8643a653 it is subject to +# Note [Sensitivity to unique increment] in T12545.hs; spread was 1.7% test ('T8095', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',2) ], + collect_compiler_stats('bytes allocated',4) ], compile, ['-v0 -O']) +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 1.5% test ('T13386', [ only_ways(['normal']), - collect_compiler_stats('bytes allocated',1) ], + collect_compiler_stats('bytes allocated',3) ], compile, ['-v0 -O0']) @@ -261,15 +265,7 @@ test('T12234', compile, ['']) -# T12545 is sensitive to -dunique-increments changes, see #19414. I've seen -# variations of as much as 4.8% by playing with that parameter, -# -# The issue with the test is that it does too little so is very sensitive to -# any small variations during initialisation and in particular populating the -# initial environments with wired-in things. Therefore it has a very high change -# threshold so we catch if it regresses a lot but don't worry if it regresses a little. -# -# You can measure the variance by running T12545.measure.sh. +# See Note [Sensitivity to unique increment] in T12545.hs; spread was 4.8% test('T12545', [ only_ways(['normal']), collect_compiler_stats('bytes allocated', 10), # ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ -test('size_hello_obj', [collect_size(3, 'size_hello_obj.o')], compile, ['']) +test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 3, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -17,7 +17,8 @@ { Test20297.hs:11:22-26 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.hs:1:1-33 }) + (EpaSpan + { Test20297.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") @@ -114,7 +115,8 @@ (AddEpAnn AnnEqual (EpaSpan { Test20297.hs:5:5 }))) (EpaComments [(L - (EpaSpan { Test20297.hs:6:3-13 }) + (EpaSpan + { Test20297.hs:6:3-13 }) (EpaComment (EpaLineComment "-- comment0") @@ -162,7 +164,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:7:9-19 }) + (EpaSpan + { Test20297.hs:7:9-19 }) (EpaComment (EpaLineComment "-- comment1") @@ -267,7 +270,8 @@ []) (EpaComments [(L - (EpaSpan { Test20297.hs:10:9-19 }) + (EpaSpan + { Test20297.hs:10:9-19 }) (EpaComment (EpaLineComment "-- comment2") @@ -436,7 +440,8 @@ { Test20297.ppr.hs:9:20-24 }))) (EpaCommentsBalanced [(L - (EpaSpan { Test20297.ppr.hs:1:1-33 }) + (EpaSpan + { Test20297.ppr.hs:1:1-33 }) (EpaComment (EpaBlockComment "{-# OPTIONS -ddump-parsed-ast #-}") ===================================== testsuite/tests/vdq-rta/should_fail/T24176.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE QuantifiedConstraints, RequiredTypeArguments #-} +module T24176 where + +f :: (forall a -> Eq a) => a +f = f ===================================== testsuite/tests/vdq-rta/should_fail/T24176.stderr ===================================== @@ -0,0 +1,8 @@ + +T24176.hs:4:7: error: [GHC-83865] + • Expected a constraint, but ‘forall a -> Eq a’ is a type + • In the type signature: f :: (forall a -> Eq a) => a + +T24176.hs:4:19: error: [GHC-83865] + • Expected a type, but ‘Eq a’ is a constraint + • In the type signature: f :: (forall a -> Eq a) => a ===================================== testsuite/tests/vdq-rta/should_fail/all.T ===================================== @@ -14,4 +14,5 @@ test('T22326_fail_patsyn', normal, compile_fail, ['']) test('T22326_fail_match', normal, compile_fail, ['']) test('T23738_fail_wild', normal, compile_fail, ['']) test('T23738_fail_implicit_tv', normal, compile_fail, ['']) -test('T23738_fail_var', normal, compile_fail, ['']) \ No newline at end of file +test('T23738_fail_var', normal, compile_fail, ['']) +test('T24176', normal, compile_fail, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -619,7 +619,7 @@ annotationsToComments (EpAnn anc a cs) l kws = do go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) go acc [] = acc go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls + | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls | otherwise = go (cs', (AddEpAnn k ss):ans) ls -- --------------------------------------------------------------------- @@ -677,7 +677,7 @@ printStringAtRsC capture pa str = do NoCaptureComments -> return [] debugM $ "printStringAtRsC:cs'=" ++ show cs' debugM $ "printStringAtRsC:p'=" ++ showAst p' - debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' NoComments) debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) return (EpaDelta p' (map comment2LEpaComment cs')) @@ -1365,14 +1365,14 @@ printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsBefore ss = do cs <- commentAllocationBefore ss debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () printCommentsIn ss = do cs <- commentAllocationIn ss debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) mapM_ printOneComment cs debugM $ "printCommentsIn:done" @@ -1423,12 +1423,12 @@ updateAndApplyComment (Comment str anc pp mo) dp = do _ -> dp'' op' = case dp' of SameLine n -> if n >= 0 - then EpaDelta dp' [] - else EpaDelta dp [] - _ -> EpaDelta dp' [] - anc' = if str == "" && op' == EpaDelta (SameLine 0) [] -- EOF comment - then EpaDelta dp [] - else EpaDelta dp [] + then EpaDelta dp' NoComments + else EpaDelta dp NoComments + _ -> EpaDelta dp' NoComments + anc' = if str == "" && op' == EpaDelta (SameLine 0) NoComments -- EOF comment + then EpaDelta dp NoComments + else EpaDelta dp NoComments -- --------------------------------------------------------------------- ===================================== utils/check-exact/Main.hs ===================================== @@ -68,6 +68,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6) + -- "../../testsuite/tests/ghc-api/exactprint/AddClassMethod.hs" (Just addClassMethod) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3) ===================================== utils/check-exact/Transform.hs ===================================== @@ -283,8 +283,9 @@ setEntryDP (L (EpAnn (EpaDelta d csd) an cs) a) dp (dp0,c') = go h in (dp0, c':t, EpaCommentsBalanced [] ts) + go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e) go (L (EpaDelta _ c0) c) = (d, L (EpaDelta dp c0) c) - go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) + go (L (EpaSpan _) c) = (d, L (EpaDelta dp NoComments) c) setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp = case sortEpaComments (priorComments cs) of [] -> @@ -293,7 +294,7 @@ setEntryDP (L (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) a) dp L (EpAnn (EpaDelta edp csd) an cs'') a where cs'' = setPriorComments cs [] - csd = L (EpaDelta dp []) c:cs' + csd = L (EpaDelta dp NoComments) c:cs' lc = last $ (L ca c:cs') delta = case getLoc lc of EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r ===================================== utils/check-exact/Types.hs ===================================== @@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators - , commentAnchor :: !Anchor + , commentLoc :: !NoCommentsLocation , commentPriorTok :: !RealSrcSpan , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } ===================================== utils/check-exact/Utils.hs ===================================== @@ -186,7 +186,7 @@ isPointSrcSpan ss = spanLength ss == 0 -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) - = (L (EpaDelta dp []) (GHC.EpaComment t pp)) + = (L (EpaDelta dp NoComments) (GHC.EpaComment t pp)) `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp)) where (r,c) = ss2posEnd pp @@ -253,7 +253,7 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s tokComment :: LEpaComment -> [Comment] tokComment t@(L lt c) = case c of - (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc + (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] @@ -268,9 +268,9 @@ hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = in (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs)) hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk)) - = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments anc pt (NestedDocString dec (L _ chunk)) - = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code @@ -301,11 +301,11 @@ mkEpaComments priorCs postCs comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r -mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment -mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r)) +mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment +mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r)) -mkComment :: String -> Anchor -> RealSrcSpan -> Comment -mkComment c anc r = Comment c anc r Nothing +mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment +mkComment c loc r = Comment c loc r Nothing -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String @@ -328,11 +328,11 @@ sortEpaComments cs = sortBy cmp cs cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> EpaLocation -> Comment +mkKWComment :: AnnKeywordId -> NoCommentsLocation -> Comment mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment (keywordToString kw) (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) mkKWComment kw (EpaSpan (UnhelpfulSpan _)) - = Comment (keywordToString kw) (EpaDelta (SameLine 0) []) placeholderRealSpan (Just kw) + = Comment (keywordToString kw) (EpaDelta (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta dp cs) = Comment (keywordToString kw) (EpaDelta dp cs) placeholderRealSpan (Just kw) @@ -481,7 +481,7 @@ hsDeclsClassDecl dec = case dec of tcdATs = ats, tcdATDefs = at_defs } -> map snd decls where - srs :: (HasLoc a) => a -> RealSrcSpan + srs :: EpAnn a -> RealSrcSpan srs a = realSrcSpan $ locA a decls = orderedDecls sortKey $ Map.fromList ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit f9f25507bf48a8b05f21759744eddc93741fd10a +Subproject commit a7eae7da6868b22dc7109142475b228c60509812 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...71cde98358a14621727b0150fe5f7913d25578c1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...71cde98358a14621727b0150fe5f7913d25578c1 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 Dec 4 05:15:02 2023 From: gitlab at gitlab.haskell.org (=?UTF-8?B?SmFrb2IgQnLDvG5rZXIgKEBKYWtvYkJydWVua2VyKQ==?=) Date: Mon, 04 Dec 2023 00:15:02 -0500 Subject: [Git][ghc/ghc][wip/jbruenker/foreach] 2 commits: wip add Erasure to ppr functions Message-ID: <656d6056e4f85_319fc153507ec42523eb@gitlab.mail> Jakob Brünker pushed to branch wip/jbruenker/foreach at Glasgow Haskell Compiler / GHC Commits: ba4ffaf6 by Jakob Bruenker at 2023-12-02T22:59:04+01:00 wip add Erasure to ppr functions - - - - - d6113cc3 by Jakob Bruenker at 2023-12-04T06:13:32+01:00 wip split off foreach added function type in tcSplit functions - - - - - 14 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/PatSyn.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/Type.hs - compiler/GHC/CoreToIface.hs-boot - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/TyThing/Ppr.hs - compiler/GHC/Types/Var.hs - compiler/Language/Haskell/Syntax/Pat.hs Changes: ===================================== compiler/GHC/Core/Coercion.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {- (c) The University of Glasgow 2006 @@ -252,7 +253,7 @@ ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkForAllTyBinders Inferred bndrs') + [ pprUserForAll (map (Erased,) $ mkForAllTyBinders Inferred bndrs') -- See Note [Printing foralls in type family instances] in GHC.Iface.Type , pp_lhs <+> ppr_rhs tidy_env ee_rhs , vcat [ text "-- Defined" <+> pp_loc ===================================== compiler/GHC/Core/PatSyn.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 @@ -6,7 +8,6 @@ -} - module GHC.Core.PatSyn ( -- * Main data types PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, @@ -502,7 +503,7 @@ pprPatSynType :: PatSyn -> SDoc pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , psExTyVars = ex_tvs, psProvTheta = prov_theta , psArgs = orig_args, psResultTy = orig_res_ty }) - = sep [ pprForAll $ tyVarSpecToBinders univ_tvs + = sep [ pprForAll $ map (Erased,) $ tyVarSpecToBinders univ_tvs , pprThetaArrowTy req_theta , ppWhen insert_empty_ctxt $ parens empty <+> darrow , pprType sigma_ty ] ===================================== compiler/GHC/Core/TyCo/Ppr.hs ===================================== @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} -- | Pretty-printing types and coercions. module GHC.Core.TyCo.Ppr @@ -27,7 +28,7 @@ module GHC.Core.TyCo.Ppr import GHC.Prelude import {-# SOURCE #-} GHC.CoreToIface - ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) import {-# SOURCE #-} GHC.Core.DataCon @@ -161,13 +162,13 @@ pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType -pprForAll :: [ForAllTyBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs) +pprForAll :: [(Erasure, ForAllTyBinder)] -> SDoc +pprForAll = pprIfaceForAll . (map . fmap) toIfaceForAllBndr -- | Print a user-level forall; see @Note [When to print foralls]@ in -- "GHC.Iface.Type". -pprUserForAll :: [ForAllTyBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs +pprUserForAll :: [(Erasure, ForAllTyBinder)] -> SDoc +pprUserForAll = pprUserIfaceForAll . (map . fmap) toIfaceForAllBndr pprTCvBndrs :: [ForAllTyBinder] -> SDoc pprTCvBndrs tvs = sep (map pprTCvBndr tvs) @@ -318,7 +319,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] where (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc - forAllDoc = pprUserForAll user_bndrs + forAllDoc = pprUserForAll $ map (Erased,) user_bndrs thetaDoc = pprThetaArrowTy theta argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys)) ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -1437,6 +1437,8 @@ piResultTy ty arg = case piResultTy_maybe ty arg of piResultTy_maybe :: Type -> Type -> Maybe Type -- We don't need a 'tc' version, because -- this function behaves the same for Type and Constraint +-- XXX JB actually we probably do need a separate tc thing, since foreach is handled differently in tc and core (check if this is still used for tc) +-- XXX JB same applies to piResultTys below piResultTy_maybe ty arg = case coreFullView ty of FunTy { ft_res = res } -> Just res @@ -1761,7 +1763,7 @@ tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder] -- Return the tyConBinders in PiTyBinder form tyConBindersPiTyBinders = map to_tyb where - to_tyb (Bndr tv (NamedTCB vis)) = Named Erased (Bndr tv vis) -- XXX JB TyConBinder is this really always Erased? + to_tyb (Bndr tv (NamedTCB vis)) = Named Erased (Bndr tv vis) -- XXX JB is this really always Erased? I think since we're dealing with type constructors the answer is yes (this is also never used) to_tyb (Bndr tv AnonTCB) = Anon (tymult (varType tv)) FTF_T_T -- | Make a dependent forall over a TyCoVar ===================================== compiler/GHC/CoreToIface.hs-boot ===================================== @@ -11,6 +11,7 @@ import GHC.Types.Var.Set( VarSet ) -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndr :: VarBndr TyCoVar flag -> VarBndr IfaceBndr flag toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TupleSections #-} module GHC.Iface.Syntax ( module GHC.Iface.Type, @@ -72,7 +73,7 @@ import GHC.Unit.Module.Warnings import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue ) -import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) +import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike, Erasure(..) ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) @@ -738,7 +739,7 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs where -- See Note [Printing foralls in type family instances] in GHC.Iface.Type ppr_binders = maybe_index <+> - pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) + pprUserIfaceForAll (map ((Erased,) . mkIfaceForAllTvBndr Specified) tvs) pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) -- See Note [Displaying axiom incompatibilities] @@ -917,7 +918,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, is_data_instance = isIfaceDataInstance parent -- See Note [Printing foralls in type family instances] in GHC.Iface.Type pp_data_inst_forall :: SDoc - pp_data_inst_forall = pprUserIfaceForAll forall_bndrs + pp_data_inst_forall = pprUserIfaceForAll $ map (Erased,) forall_bndrs forall_bndrs :: [IfaceForAllBndr] forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] @@ -1133,8 +1134,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, , pprIfaceType $ foldr (IfaceFunTy visArgTypeLike many_ty) pat_ty arg_tys ]) pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls - univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs - ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs + univ_msg = pprUserIfaceForAll $ map (Erased,) $ tyVarSpecToBinders univ_bndrs + ex_msg = pprUserIfaceForAll $ map (Erased,) $ tyVarSpecToBinders ex_bndrs insert_empty_ctxt = null req_ctxt && not (null prov_ctxt && isEmpty sdocCtx ex_msg) @@ -1262,9 +1263,9 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- the visibilities of the existential tyvar binders, we can simply drop -- the universal tyvar binders from user_tvbs. ex_tvbs = dropList tc_binders user_tvbs - ppr_ex_quant = pprIfaceForAllPartMust (ifaceForAllSpecToBndrs ex_tvbs) ctxt + ppr_ex_quant = pprIfaceForAllPartMust (map (Erased,) $ ifaceForAllSpecToBndrs ex_tvbs) ctxt pp_gadt_res_ty = mk_user_con_res_ty eq_spec - ppr_gadt_ty = pprIfaceForAllPart (ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau + ppr_gadt_ty = pprIfaceForAllPart (map (Erased,) $ ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -476,7 +476,7 @@ isIfaceLifted (IfaceTyConApp tc args) = True isIfaceLifted _ = False -splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +splitIfaceSigmaTy :: IfaceType -> ([(Erasure, IfaceForAllBndr)], [IfacePredType], IfaceType) -- Mainly for printing purposes -- -- Here we split nested IfaceSigmaTy properly. @@ -500,9 +500,9 @@ splitIfaceSigmaTy ty (theta, tau) = split_rho rho -- XXX JB Iface do we need to check the erasure here? - split_foralls (IfaceForAllTy _ bndr ty) + split_foralls (IfaceForAllTy eras bndr ty) | isInvisibleForAllTyFlag (binderFlag bndr) - = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + = case split_foralls ty of { (bndrs, rho) -> ((eras, bndr):bndrs, rho) } split_foralls rho = ([], rho) split_rho (IfaceFunTy af _ ty1 ty2) @@ -510,11 +510,10 @@ splitIfaceSigmaTy ty = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) -splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType) --- XXX JB Iface do we need to check the erasure here? -splitIfaceReqForallTy (IfaceForAllTy _ bndr ty) +splitIfaceReqForallTy :: IfaceType -> ([(Erasure, IfaceForAllBndr)], IfaceType) +splitIfaceReqForallTy (IfaceForAllTy eras bndr ty) | isVisibleForAllTyFlag (binderFlag bndr) - = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + = case splitIfaceReqForallTy ty of { (bndrs, rho) -> ((eras, bndr):bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a] @@ -1275,12 +1274,12 @@ ppr_app_arg ctx_prec (t, argf) = _ -> empty ------------------- -pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPart :: [(Erasure, IfaceForAllBndr)] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc -- | Like 'pprIfaceForAllPart', but always uses an explicit @forall at . -pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPartMust :: [(Erasure, IfaceForAllBndr)] -> [IfacePredType] -> SDoc -> SDoc pprIfaceForAllPartMust tvs ctxt sdoc = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc @@ -1289,9 +1288,8 @@ pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs, sdoc ] --- XXX JB HERE printing this needs to be fixed ppr_iface_forall_part :: ShowForAllFlag - -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc + -> [(Erasure, IfaceForAllBndr)] -> [IfacePredType] -> SDoc -> SDoc ppr_iface_forall_part show_forall tvs ctxt sdoc = sep [ case show_forall of ShowForAllMust -> pprIfaceForAll tvs @@ -1300,13 +1298,13 @@ ppr_iface_forall_part show_forall tvs ctxt sdoc , sdoc] -- | Render the "forall ... ." or "forall ... ->" bit of a type. -pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll :: [(Erasure, IfaceForAllBndr)] -> SDoc pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(Bndr _ vis : _) - = sep [ add_separator (forAllLit <+> fsep docs) +pprIfaceForAll bndrs@((eras, Bndr _ vis) : _) + = sep [ add_separator ((if eras == Erased then forAllLit else forEachLit) <+> fsep docs) , pprIfaceForAll bndrs' ] where - (bndrs', docs) = ppr_itv_bndrs bndrs vis + (bndrs', docs) = ppr_itv_bndrs bndrs eras vis add_separator stuff = case vis of Required -> stuff <+> arrow @@ -1316,14 +1314,16 @@ pprIfaceForAll bndrs@(Bndr _ vis : _) -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. -- Returns both the list of not-yet-rendered binders and the doc. -- No anonymous binders here! -ppr_itv_bndrs :: [IfaceForAllBndr] +ppr_itv_bndrs :: [(Erasure, IfaceForAllBndr)] + -> Erasure -- ^ erasure of the first binder in the list -> ForAllTyFlag -- ^ visibility of the first binder in the list - -> ([IfaceForAllBndr], [SDoc]) -ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 - | vis `eqForAllVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + -> ([(Erasure, IfaceForAllBndr)], [SDoc]) +ppr_itv_bndrs all_bndrs@((eras, bndr@(Bndr _ vis)) : bndrs) eras1 vis1 + | eras == eras1 + , vis `eqForAllVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs eras1 vis1 in (bndrs', pprIfaceForAllBndr bndr : doc) | otherwise = (all_bndrs, []) -ppr_itv_bndrs [] _ = ([], []) +ppr_itv_bndrs [] _ _ = ([], []) pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCo [] = empty @@ -1409,14 +1409,15 @@ ppr_sigma show_forall ctxt_prec iface_ty in ppr_iface_forall_part show_forall invis_tvs theta $ sep [pprIfaceForAll req_tvs, ppr_ty_nested tau'] -pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc -pprUserIfaceForAll tvs +pprUserIfaceForAll :: [(Erasure, IfaceForAllBndr)] -> SDoc +pprUserIfaceForAll etvs + | let tvs = map snd etvs = sdocOption sdocPrintExplicitForalls $ \print_foralls -> -- See Note [When to print foralls] in this module. ppWhen (any tv_has_kind_var tvs || any tv_is_required tvs || print_foralls) $ - pprIfaceForAll tvs + pprIfaceForAll etvs where tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) = not (ifTypeIsVarFree kind) ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -637,12 +637,19 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- Rule ITVDQ from the GHC Proposal #281 go1 delta acc so_far fun_ty ((EValArg { eva_arg = ValArg arg }) : rest_args) - | Just (eras, tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty -- XXX JB HERE + | Just (Erased, tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty , binderFlag tvb == Required = do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg ; let wrap = mkWpTyApps [ty_arg] ; go delta (addArgWrap wrap acc) so_far inst_body rest_args } + go1 delta acc so_far fun_ty ((EValArg { eva_arg = ValArg arg }) : rest_args) + | Just (Retained, tvb, body) <- tcSplitForAllTyVarBinder_maybe fun_ty -- XXX JB HERE + , binderFlag tvb == Required -- XXX JB what if it's not required? How is regular forall handled in that case? + = do { (ty_arg, inst_body) <- tcVDQ fun_conc_tvs (tvb, body) arg + ; let wrap = mkWpTyApps [ty_arg] + ; go delta (addArgWrap wrap acc) so_far inst_body rest_args } + -- Rule IRESULT from Fig 4 of the QL paper go1 delta acc _ fun_ty [] = do { traceTc "tcInstFun:ret" (ppr fun_ty) @@ -983,6 +990,7 @@ Syntax of applications in HsExpr This nesting makes `type` rather different from `@`. Remember, the HsEmbTy mainly just switches namespace, and is subject to the term-to-type transformation. +-- XXX JB note update Syntax of abstractions in Pat ----------------------------- * Type patterns are represented in Pat roughly like this ===================================== compiler/GHC/Tc/Solver/Rewrite.hs ===================================== @@ -1100,7 +1100,7 @@ ty_con_binders_ty_binders' :: [TyConBinder] -> ([PiTyBinder], Bool) ty_con_binders_ty_binders' = foldr go ([], False) where go (Bndr tv (NamedTCB vis)) (bndrs, _) - = (Named Erased (Bndr tv vis) : bndrs, True) -- XXX JB Named is it really always Erased? + = (Named Erased (Bndr tv vis) : bndrs, True) -- XXX JB Named is it really always Erased? I think since we're dealing with type constructors the answer is yes go (Bndr tv AnonTCB) (bndrs, n) = (Anon (tymult (tyVarKind tv)) FTF_T_T : bndrs, n) {-# INLINE go #-} ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} {- (c) The University of Glasgow 2006 @@ -893,7 +895,7 @@ tcTyFamInstsAndVisX = go | otherwise = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys go _ (LitTy {}) = [] - go is_invis_arg (ForAllTy _ bndr ty) = go is_invis_arg (binderType bndr) + go is_invis_arg (ForAllTyWithFun _ bndr ty) = go is_invis_arg (binderType bndr) ++ go is_invis_arg ty go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w ++ go is_invis_arg ty1 @@ -972,7 +974,7 @@ any_rewritable role tv_pred tc_pred should_expand go rl bvs arg || go rl bvs res || go NomEq bvs w where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 res_rep = getRuntimeRep res - go rl bvs (ForAllTy _ tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty + go rl bvs (ForAllTyWithFun _ tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty go rl bvs (CastTy ty _) = go rl bvs ty go _ _ (CoercionTy _) = False @@ -1328,7 +1330,7 @@ getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (FunTy { ft_af = af }) = getOccName (funTyFlagTyCon af) -getDFunTyKey (ForAllTy _ _ t) = getDFunTyKey t +getDFunTyKey (ForAllTyWithFun _ _ t) = getDFunTyKey t getDFunTyKey (CastTy ty _) = getDFunTyKey ty getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) @@ -1345,13 +1347,35 @@ getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n) ************************************************************************ -} +-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder, but assumes that any coreView stuff is already done +tcSplitForAllForAllTyBinderNoView_maybe :: Type -> Maybe (Erasure, ForAllTyBinder, Type) +tcSplitForAllForAllTyBinderNoView_maybe (ForAllTy Erased bndr inner_ty) = Just (Erased, bndr, inner_ty) +tcSplitForAllForAllTyBinderNoView_maybe (ForAllTy Retained bndr (FunTy FTF_T_T mult arg_ty inner_ty)) = + assert (eqType (binderType bndr) arg_ty) . assert (eqType mult manyDataConTy) $ + Just (Retained, bndr, inner_ty) +tcSplitForAllForAllTyBinderNoView_maybe (ForAllTy Retained _ _) = + panic "tcSplitForAllForAllTyBinderNoView_maybe: Retained binder without matching FunTy" +tcSplitForAllForAllTyBinderNoView_maybe _ = Nothing + +-- | Acts like ForAllTy, but for retained binders additionally removes the function type that is added in Core +pattern ForAllTyWithFun :: Erasure -> ForAllTyBinder -> Type -> Type +pattern ForAllTyWithFun eras bndr ty <- (tcSplitForAllForAllTyBinderNoView_maybe -> Just (eras, bndr, ty)) +{-# COMPLETE TyVarTy, AppTy, TyConApp, ForAllTyWithFun, FunTy, LitTy, CastTy, CoercionTy #-} + -- | Splits a forall type into a list of 'PiTyVarBinder's and the inner type. -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) tcSplitPiTys ty = assert (all isTyBinder (fst sty)) -- No CoVar binders here sty - where sty = splitPiTys ty + where + sty = split ty ty [] + + split _ (ForAllTyWithFun eras b res) bs = split res res (Named eras b : bs) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs + = split res res (Anon (Scaled w arg) af : bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) -- | Splits a type into a PiTyVarBinder and a body, if possible. tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type) @@ -1359,18 +1383,20 @@ tcSplitPiTy_maybe ty = assert (isMaybeTyBinder sty) -- No CoVar binders here sty where - sty = splitPiTy_maybe ty + sty = tc_split_pi_ty_maybe ty isMaybeTyBinder (Just (t,_)) = isTyBinder t isMaybeTyBinder _ = True + tc_split_pi_ty_maybe :: Type -> Maybe (PiTyBinder, Type) + tc_split_pi_ty_maybe ty = case coreFullView ty of + ForAllTyWithFun eras bndr ty -> Just (Named eras bndr, ty) + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> Just (Anon (mkScaled w arg) af, res) + _ -> Nothing + tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (Erasure, TyVarBinder, Type) tcSplitForAllTyVarBinder_maybe ty | Just ty' <- coreView ty = tcSplitForAllTyVarBinder_maybe ty' -tcSplitForAllTyVarBinder_maybe (ForAllTy Retained tv (FunTy FTF_T_T mult arg_ty ty)) = - assert (isTyVarBinder tv) . assert (eqType (binderType tv) arg_ty) . assert (eqType mult manyDataConTy) $ - Just (Retained, tv, ty) -tcSplitForAllTyVarBinder_maybe (ForAllTy Retained _ _) = - panic "tcSplitForAllTyVarBinder_maybe: Retained binder without matching FunTy" -tcSplitForAllTyVarBinder_maybe (ForAllTy Erased tv ty) = assert (isTyVarBinder tv ) Just (Erased, tv, ty) +tcSplitForAllTyVarBinder_maybe (ForAllTyWithFun eras tv ty) = assert (isTyVarBinder tv ) Just (eras, tv, ty) tcSplitForAllTyVarBinder_maybe _ = Nothing -- | Like 'tcSplitPiTys', but splits off only named binders, @@ -1378,7 +1404,12 @@ tcSplitForAllTyVarBinder_maybe _ = Nothing tcSplitForAllTyVars :: Type -> ([TyVar], Type) tcSplitForAllTyVars ty = assert (all isTyVar (fst sty)) sty - where sty = splitForAllTyCoVars ty + where + sty = split ty ty [] + + split _ (ForAllTyWithFun _ (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' -- type variable binders. @@ -1393,7 +1424,7 @@ tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type) tcSplitSomeForAllTyVars argf_pred ty = split ty ty [] where - split _ (ForAllTy _ (Bndr tv argf) ty) tvs + split _ (ForAllTyWithFun _ (Bndr tv argf) ty) tvs | argf_pred argf = split ty ty (tv:tvs) split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) @@ -1402,18 +1433,33 @@ tcSplitSomeForAllTyVars argf_pred ty -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type) tcSplitForAllReqTVBinders ty = assert (all isTyVarBinder (fst sty) ) sty - where sty = splitForAllReqTyBinders ty + where + sty = split ty ty [] + + split _ (ForAllTyWithFun _ (Bndr tv Required) ty) tvs = split ty ty (Bndr tv ():tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'. tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type) tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty)) sty - where sty = splitForAllInvisTyBinders ty + where + sty = split ty ty [] + + split _ (ForAllTyWithFun _ (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'tcSplitForAllTyVars', but splits off only named binders. tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type) tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty - where sty = splitForAllForAllTyBinders ty + where + sty = split ty ty [] + + split _ (ForAllTyWithFun _ b res) bs = split res res (b:bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type @@ -1892,7 +1938,7 @@ isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ _ ty) = isOverloadedTy ty +isOverloadedTy (ForAllTyWithFun _ _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af isOverloadedTy _ = False @@ -2232,7 +2278,7 @@ pSizeTypeX bvs (TyConApp tc tys) = pSizeTyConAppX bvs tc tys pSizeTypeX bvs (AppTy fun arg) = pSizeTypeX bvs fun `addPSize` pSizeTypeX bvs arg pSizeTypeX bvs (FunTy _ w arg res) = pSizeTypeX bvs w `addPSize` pSizeTypeX bvs arg `addPSize` pSizeTypeX bvs res -pSizeTypeX bvs (ForAllTy _ (Bndr tv _) ty) = pSizeTypeX bvs (tyVarKind tv) `addPSize` +pSizeTypeX bvs (ForAllTyWithFun _ (Bndr tv _) ty) = pSizeTypeX bvs (tyVarKind tv) `addPSize` pSizeTypeX (bvs `extendVarSet` tv) ty pSizeTypeX bvs (CastTy ty _) = pSizeTypeX bvs ty pSizeTypeX _ (CoercionTy {}) = pSizeOne ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -388,6 +388,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside where -- Skolemise any /invisible/ foralls /before/ the zero-arg case -- so that we guarantee to return a rho-type + -- XXX JB do we need to do something different here for foreach? E.g. should tcSplitSigma return Erasure for each tv? go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below @@ -403,6 +404,13 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n ty | Just ty' <- coreView ty = go acc_arg_tys n ty' + -- XXX JB these actually aren't here I just need to put this somewhere + -- XXX JB HERE HERE: right now \x -> x (or undefined) :: foreach x -> x results in a stack overflow :thinking: + -- XXX JB HERE HERE: foo :: foreach x -> Int; foo x = 4 right now has type `forall (x :: k) -> k -> Int`. Should be foreach I guess + -- XXX JB HERE HERE: :t undefined :: foreach x -> x results in Couldn't match expected type forall x -> * -> x with actual type a0 + -- XXX JB HERE example of core lint failure: let foo :: foreach x -> Int; foo (type x) = 4 + -- XXX JB HERE the above works without -dlint, except when you run `:t foo (type True)", it then says "Bool -> Int" + -- XXX JB "foo :: foreach x . Int; foo = 4" fails - and that makes sense, we're not stripping the foreach anywhere, so also not stripping the function type - uhh though actually I guess I see no reason why tcSplitForAllTyVarBinder or some variant wouldn't be called when checking the type, now that I think about it (seems like it might not be useful to have a retained arg on which you don't match, but what if you use pointfree style?) -- Decompose /visible/ (forall a -> blah), to give an ExpForAllPat -- NB: invisible binders are handled by tcSplitSigmaTy/tcTopSkolemise above @@ -410,7 +418,6 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside -- to syntactically visible patterns in the source program -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App go acc_arg_tys n ty - -- XXX JB HERE Maybe this should use the tc version of splitForAllTys (and then splitForAllTys can stop removing the function type) | Just (eras, Bndr tv vis, ty') <- tcSplitForAllTyVarBinder_maybe ty , Required <- vis = let init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) ===================================== compiler/GHC/Types/TyThing/Ppr.hs ===================================== @@ -6,6 +6,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE TupleSections #-} + module GHC.Types.TyThing.Ppr ( pprTyThing, @@ -20,6 +22,7 @@ import GHC.Prelude import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name +import GHC.Types.Var ( Erasure(..) ) import GHC.Core.Type ( ForAllTyFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) @@ -120,7 +123,7 @@ pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs }) = showWithLoc (pprDefinedAt (getName axiom)) $ hang (text "type instance" - <+> pprUserForAll (mkTyVarBinders Specified tvs) + <+> pprUserForAll (map (Erased,) $ mkTyVarBinders Specified tvs) -- See Note [Printing foralls in type family instances] -- in GHC.Iface.Type <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -470,6 +470,7 @@ data Specificity = InferredSpec deriving (Eq, Ord, Data) -- | Whether a dependent argument is erased at runtime +-- XXX JB maybe this should be added to ForAllTyFlag? data Erasure = Erased | Retained deriving (Eq, Ord, Data) ===================================== compiler/Language/Haskell/Syntax/Pat.hs ===================================== @@ -221,6 +221,8 @@ data Pat p -- Embed the syntax of types into patterns. -- Used with RequiredTypeArguments or Foreach, e.g. fn (type t) = rhs + -- XXX JB Once we allow type patterns without the type herald, we'll probably have to add to the Tc extension point of some other constructor here whether that pattern is retained in some way. + -- XXX JB ...and somehow we also need to handle invisible foreach, like... we need to add an extra pattern for it for the retained type argument, even though there's no existing pattern as in `foreach x . 4 | EmbTyPat (XEmbTyPat p) !(LHsToken "type" p) (HsTyPat (NoGhcTc p)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f14e085001a9b659b93c2fa7582a67b5d51e57a...d6113cc3de570e52e193e403ca74c87b8a179b2c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f14e085001a9b659b93c2fa7582a67b5d51e57a...d6113cc3de570e52e193e403ca74c87b8a179b2c 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 Dec 4 10:49:54 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Mon, 04 Dec 2023 05:49:54 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/bump-unix-filepath Message-ID: <656daed2d174f_319fc15ab8c9dc2750a7@gitlab.mail> Matthew Pickering pushed new branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/bump-unix-filepath 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 Dec 4 11:14:56 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 04 Dec 2023 06:14:56 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Message-ID: <656db4b016b5b_319fc15b815e382802cd@gitlab.mail> Zubin pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: 8fd747ee by Matthew Pickering at 2023-12-04T16:44:18+05:30 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 - - - - - 2 changed files: - libraries/filepath - libraries/unix Changes: ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4 +Subproject commit cdb5171f7774569b1a8028a78392cfa79f732b5c ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit 5211c230903aee8c09485e8246993e2a1eb74563 +Subproject commit 0b3dbc9901fdf2d752c4ee7a7cee7b1ed20e76bd View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fd747eef0078fc616b8de66db0842566d1f00b9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fd747eef0078fc616b8de66db0842566d1f00b9 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 Dec 4 12:04:36 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Mon, 04 Dec 2023 07:04:36 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] Submodule linter: Allow references to tags Message-ID: <656dc05459ff7_319fc15d172b8828979f@gitlab.mail> Matthew Pickering pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: e3a3cb6a by Matthew Pickering at 2023-12-04T12:04:19+00: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. - - - - - 2 changed files: - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs Changes: ===================================== linters/lint-submodule-refs/Main.hs ===================================== @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return False + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return True if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + ===================================== linters/linters-common/Linters/Common.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3a3cb6a6f0fe195c1d542982a64de70cfb556cb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e3a3cb6a6f0fe195c1d542982a64de70cfb556cb 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 Dec 4 12:13:53 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Mon, 04 Dec 2023 07:13:53 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] Submodule linter: Allow references to tags Message-ID: <656dc281b0bfe_319fc15d172b88296060@gitlab.mail> Matthew Pickering pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: 0765cedb by Matthew Pickering at 2023-12-04T12:13:40+00: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 - - - - - 2 changed files: - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs Changes: ===================================== linters/lint-submodule-refs/Main.hs ===================================== @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return True + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return False if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + ===================================== linters/linters-common/Linters/Common.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0765cedbaa7932fa957d74711568c2bd0237e69e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0765cedbaa7932fa957d74711568c2bd0237e69e 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 Dec 4 12:55:36 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 04 Dec 2023 07:55:36 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] hadrian: set -Wno-deprecations for directory Message-ID: <656dcc4897985_319fc15e3e50b8303969@gitlab.mail> Zubin pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: 227b47b3 by Zubin Duggal at 2023-12-04T18:23:51+05:30 hadrian: set -Wno-deprecations for directory 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 - - - - - 1 changed file: - hadrian/src/Settings/Warnings.hs Changes: ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -35,7 +35,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/227b47b3e84b4ffee1ebef012d3635b59de7caac -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/227b47b3e84b4ffee1ebef012d3635b59de7caac 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 Dec 4 13:35:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 04 Dec 2023 08:35:27 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] hadrian: set -Wno-deprecations for directory Message-ID: <656dd59f3f866_319fc15f9975503098f7@gitlab.mail> Zubin pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: 19b5346e by Zubin Duggal at 2023-12-04T19:05:14+05:30 hadrian: set -Wno-deprecations for directory 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 - - - - - 1 changed file: - hadrian/src/Settings/Warnings.hs Changes: ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -35,7 +35,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19b5346ea8389bbec5b4358c016880eeaafcfff2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19b5346ea8389bbec5b4358c016880eeaafcfff2 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 Dec 4 16:47:18 2023 From: gitlab at gitlab.haskell.org (Hassan Al-Awwadi (@hassan.awwadi)) Date: Mon, 04 Dec 2023 11:47:18 -0500 Subject: [Git][ghc/ghc][wip/T24040-ghci-timeout] 17 commits: distrib: Rediscover otool and install_name_tool on Darwin Message-ID: <656e02966fc5d_319fc163b819e83639a8@gitlab.mail> Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout at Glasgow Haskell Compiler / GHC Commits: 13855309 by Ben Gamari at 2023-12-04T17:46:35+01: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. - - - - - 0d541871 by Stefan Schulze Frielinghaus at 2023-12-04T17:46:35+01: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. - - - - - 20f91d2c by Matthew Pickering at 2023-12-04T17:46:36+01: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%. - - - - - be5206d6 by Alan Zimmerman at 2023-12-04T17:46:36+01: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 - - - - - e09261ae by Sebastian Graf at 2023-12-04T17:46:36+01: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. - - - - - f2f7a19d by Alan Zimmerman at 2023-12-04T17:46:36+01: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 - - - - - d1ae80e3 by Krzysztof Gogolewski at 2023-12-04T17:46:36+01: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 - - - - - 74b1f81b by Owen Shepherd at 2023-12-04T17:46:36+01:00 docs(NonEmpty/group): Remove incorrect haddock link quotes in code block - - - - - 526bde57 by Owen Shepherd at 2023-12-04T17:46:36+01:00 docs(NonEmpty/group): Remove cycle from group haddock example - - - - - 503920aa by Owen Shepherd at 2023-12-04T17:46:36+01:00 docs(NonEmpty/group): Use repl haddock syntax in group docs - - - - - 4b8277ec by Owen Shepherd at 2023-12-04T17:46:36+01:00 docs(NonEmpty/group): Use list [] notation in group haddock - - - - - edfe9726 by Owen Shepherd at 2023-12-04T17:46:36+01:00 docs(NonEmpty/group): Specify final property of group function in haddock - - - - - 098aa867 by Owen Shepherd at 2023-12-04T17:46:36+01:00 fix: Add missing property of List.group - - - - - fc626e32 by Matthew Pickering at 2023-12-04T17:46:36+01: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. - - - - - cd3fc9e3 by Matthew Pickering at 2023-12-04T17:46:36+01:00 testsuite: Track size of libdir in bytes For consistency it's better if we track all size metrics in bytes. Metric Increase: libdir - - - - - e70f67e3 by Matthew Pickering at 2023-12-04T17:46:36+01:00 testsuite: Remove rogue trace in testsuite I accidentally left a trace in the generics metric patch. - - - - - 8d762a6d by Hassan Al-Awwadi at 2023-12-04T17:46:36+01:00 slightly more genera "withTimeLimit", which is good - - - - - 30 changed files: - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - distrib/configure.ac.in - ghc/GHCi/UI.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/dependent/should_fail/T16326_Fail12.stderr - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - testsuite/tests/perf/compiler/T12545.hs - testsuite/tests/perf/compiler/T13386.hs - testsuite/tests/perf/compiler/T8095.hs - testsuite/tests/perf/compiler/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/vdq-rta/should_fail/T24176.hs - + testsuite/tests/vdq-rta/should_fail/T24176.stderr - testsuite/tests/vdq-rta/should_fail/all.T - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...8d762a6dc8c65e3dfb1626f54f30edaf31a6fd43 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1082b52392938e42ec3a2e69f5d775dbebe92f01...8d762a6dc8c65e3dfb1626f54f30edaf31a6fd43 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 Dec 4 21:31:58 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Mon, 04 Dec 2023 16:31:58 -0500 Subject: [Git][ghc/ghc][wip/int-index/p2tp] 13 commits: perf tests: Move comments into new `Note [Sensitivity to unique increment]` (#19414) Message-ID: <656e454e7aae4_319fc16ab764b039393e@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/p2tp at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 4a81a695 by Vladislav Zavialov at 2023-12-05T00:30:42+03: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 - - - - - 30 changed files: - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/dependent/should_fail/T16326_Fail12.stderr - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - testsuite/tests/module/mod132.stderr - testsuite/tests/module/mod147.stderr - testsuite/tests/perf/compiler/T12545.hs - testsuite/tests/perf/compiler/T13386.hs - testsuite/tests/perf/compiler/T8095.hs - testsuite/tests/perf/compiler/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T - testsuite/tests/printer/Test20297.stdout - testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr - testsuite/tests/rename/should_fail/T18740a.stderr - testsuite/tests/rename/should_fail/T18740b.stderr - testsuite/tests/th/T14627.stderr - testsuite/tests/th/T18740c.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e5b055408767290bf33a5d44ad8919e551b9599...4a81a6953b82554018c9aa244e0da0f4741e2f0b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e5b055408767290bf33a5d44ad8919e551b9599...4a81a6953b82554018c9aa244e0da0f4741e2f0b 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 Dec 4 23:19:32 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Mon, 04 Dec 2023 18:19:32 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/az/epa-hslet-tokens Message-ID: <656e5e8419e52_319fc16cfcbdb0396229@gitlab.mail> Alan Zimmerman pushed new branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-hslet-tokens 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 Dec 5 08:00:48 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 05 Dec 2023 03:00:48 -0500 Subject: [Git][ghc/ghc][wip/bump-unix-filepath] hadrian: set -Wno-deprecations for directory and Win32 Message-ID: <656ed8b08c29d_319fc17971ed044450f3@gitlab.mail> Zubin pushed to branch wip/bump-unix-filepath at Glasgow Haskell Compiler / GHC Commits: 45d4b4a0 by Zubin Duggal at 2023-12-05T13:30:33+05:30 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 - - - - - 1 changed file: - hadrian/src/Settings/Warnings.hs Changes: ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -35,7 +35,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" @@ -60,5 +62,7 @@ ghcWarningsArgs = do , "-Wno-redundant-constraints" , "-Wno-orphans" ] , package unix ? pure [ "-Wno-deprecations" ] - , package win32 ? pure [ "-Wno-trustworthy-safe" ] + , package win32 ? pure [ "-Wno-trustworthy-safe" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45d4b4a0677c4931377ab863c114882719bac9b2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/45d4b4a0677c4931377ab863c114882719bac9b2 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 Dec 5 10:20:59 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Tue, 05 Dec 2023 05:20:59 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T23862 Message-ID: <656ef98b3733a_319fc17cdd39d04652f4@gitlab.mail> Sebastian Graf pushed new branch wip/T23862 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23862 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 Dec 5 10:31:56 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Tue, 05 Dec 2023 05:31:56 -0500 Subject: [Git][ghc/ghc][wip/T23862] Cpr: Turn an assertion into a check to deal with some dead code (#23862) Message-ID: <656efc1cc2564_319fc17d4d8a784752a0@gitlab.mail> Sebastian Graf pushed to branch wip/T23862 at Glasgow Haskell Compiler / GHC Commits: 2a90dd5e by Sebastian Graf at 2023-12-05T11:31:50+01: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. - - - - - 4 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - + testsuite/tests/cpranal/should_compile/T23862.hs - + testsuite/tests/cpranal/should_compile/T23862.stderr - testsuite/tests/cpranal/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -274,7 +274,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) | DataAlt dc <- con , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty - , assert (arity == 0 ) True + , arity == 0 -- See Note [Dead code may contain type confusions] = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr @@ -430,6 +430,43 @@ cprFix orig_env orig_pairs (id', rhs', env') = cprAnalBind env id rhs {- +Note [Dead code may contain type confusions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In T23862, we have a nested case match that looks like this + + data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + data family Result (check :: Bool) a + data instance Result True a = CheckedResult a + newtype instance Result True a = UncheckedResult a + + case m () of Checked co1 -> + case m () of Unchecked co2 -> + case ((\_ -> True) + |> .. UncheckedResult .. + |> sym co2 + |> co1) :: Result True (Bool -> Bool) of + CheckedResult f -> CheckedResult (f True) + +Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` +cases are apart. +However, both constructors introduce mutually contradictory coercions `co1` and +`co2` along which GHC generates a type confusion: + + 1. (\_ -> True) :: Bool -> Bool + 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) + 3. |> ... sym co1 ... :: Result check (Bool -> Bool) + 4. |> ... co2 ... :: Result True (Bool -> Bool) + +Note that we started with a function, injected into `Result` via a newtype +instance and then match on it with a datatype instance. + +We have to handle this case gracefully in `cprAnalAlt`, where for the innermost +case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that +abstracts the function `(\_ -> True)` with arity 1. +In this case, don't pretend we know anything about the fields of `CheckedResult`! + Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: ===================================== testsuite/tests/cpranal/should_compile/T23862.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} + +module T23862 where + +data family Result (check :: Bool) a +data instance Result True a = CheckedResult a +newtype instance Result False a = UncheckedResult a + +data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + +app :: (() -> CheckSingleton check) -> Result check Bool +app m = case (m (), m ()) of + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\_ -> True) + -> CheckedResult (x True) ===================================== testsuite/tests/cpranal/should_compile/T23862.stderr ===================================== @@ -0,0 +1,18 @@ + +T23862.hs:17:12: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)] + • Inaccessible code in + a pattern with constructor: Unchecked :: CheckSingleton False, + in a case alternative + Couldn't match type ‘True’ with ‘False’ + • In the pattern: Unchecked + In the pattern: (Checked, Unchecked) + In a case alternative: + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\ _ -> True) + -> CheckedResult (x True) + +T23862.hs:18:6: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In a case alternative: + (Checked, Unchecked) | CheckedResult x <- UncheckedResult + (\ _ -> True) -> ... ===================================== testsuite/tests/cpranal/should_compile/all.T ===================================== @@ -22,3 +22,5 @@ test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsu test('T18824', [ grep_errmsg(r'JoinId[^\n]*Cpr') ], compile, ['-ddump-exitify -dppr-cols=1000 -dsuppress-uniques']) test('T20539', [], compile, ['']) # simply should not crash + +test('T23862', [], compile, ['']) # simply should not crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a90dd5e74a64291fd81374099d7422e2ae84721 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a90dd5e74a64291fd81374099d7422e2ae84721 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 Dec 5 10:59:17 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Tue, 05 Dec 2023 05:59:17 -0500 Subject: [Git][ghc/ghc][wip/T24234] Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234) Message-ID: <656f0285f1c3d_319fc17e166e3448051e@gitlab.mail> Sebastian Graf pushed to branch wip/T24234 at Glasgow Haskell Compiler / GHC Commits: 9f1cb4c9 by Sebastian Graf at 2023-12-05T11:59:08+01: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". - - - - - 12 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Utils.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/ado/T22483.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - + testsuite/tests/pmcheck/should_compile/T24234.hs - + testsuite/tests/pmcheck/should_compile/T24234.stderr - testsuite/tests/pmcheck/should_compile/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1469,6 +1469,21 @@ pprGRHS ctxt (GRHS _ guards body) pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator LamAlt{} = text "->" +matchSeparator IfAlt = text "->" +matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern +matchSeparator PatSyn = text "<-" -- match checker trace +matchSeparator LazyPatCtx = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" + instance Outputable GrhsAnn where ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s @@ -1931,6 +1946,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where ppr ThPatSplice = text "ThPatSplice" ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" + ppr LazyPatCtx = text "LazyPatCtx" instance Outputable HsLamVariant where ppr = text . \case @@ -1981,6 +1997,7 @@ matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (Stm matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour +matchContextErrString LazyPatCtx = text "irrefutable pattern" matchArrowContextErrString :: HsArrowMatchContext -> SDoc matchArrowContextErrString ProcExpr = text "proc" @@ -2022,20 +2039,6 @@ pprStmtInCtxt ctxt stmt , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt -matchSeparator :: HsMatchContext p -> SDoc -matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator StmtCtxt{} = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern -matchSeparator PatSyn = text "<-" -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" - pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContext ctxt @@ -2045,6 +2048,7 @@ pprMatchContext ctxt want_an (FunRhs {}) = True -- Use "an" in front want_an (ArrowMatchCtxt ProcExpr) = True want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True + want_an LazyPatCtx = True want_an _ = False pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) @@ -2065,6 +2069,7 @@ pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration" +pprMatchContextNoun LazyPatCtx = text "irrefutable pattern" pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -237,7 +237,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss ; body_expr <- dsGuarded grhss ty rhss_nablas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body' -- We silently ignore inline pragmas; no makeCorePair -- Not so cool, but really doesn't matter ; let force_var' = if isBangedLPat pat' ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -451,13 +451,13 @@ tidy1 v _ (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) + = putSrcSpanDs (getLocA pat) $ + do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLocA pat) $ diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } ===================================== compiler/GHC/HsToCore/Pmc.hs ===================================== @@ -118,6 +118,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p then id else discardWarningsDs want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True want_pmc (StmtCtxt stmt_ctxt) = case stmt_ctxt of PatGuard {} -> False ===================================== compiler/GHC/HsToCore/Pmc/Utils.hs ===================================== @@ -91,6 +91,7 @@ exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd +exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing exhaustiveWarningFlag ThPatQuote = Nothing ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -597,7 +597,12 @@ mkSelectorBinds is used to desugar a pattern binding {p = e}, in a binding group: let { ...; p = e; ... } in body where p binds x,y (this list of binders can be empty). -There are two cases. + +mkSelectorBinds is also used to desugar irrefutable patterns, which is the +pattern syntax equivalent of a lazy pattern binding: + f (~(a:as)) = rhs ==> f x = let (a:as) = x in rhs + +There are three cases. ------ Special case (A) ------- For a pattern that is just a variable, @@ -634,7 +639,7 @@ There are two cases. Note that (C) /includes/ the situation where * The pattern binds exactly one variable - let !(Just (Just x) = e in body + let !(Just (Just x)) = e in body ==> let { t = case e of Just (Just v) -> Solo v ; v = case t of Solo v -> v } @@ -726,15 +731,16 @@ work out well: -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced. -mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound +mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> HsMatchContext GhcTc -- ^ Where the pattern occurs + -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") -- and all the desugared binds -mkSelectorBinds ticks pat val_expr +mkSelectorBinds ticks pat ctx val_expr | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) @@ -745,7 +751,7 @@ mkSelectorBinds ticks pat val_expr ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + = do { rhs_expr <- matchSimply (Var val_var) ctx pat' (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the @@ -760,7 +766,7 @@ mkSelectorBinds ticks pat val_expr | otherwise -- General case (C) = do { tuple_var <- newSysLocalDs ManyTy tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat + ; tuple_expr <- matchSimply val_expr ctx pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -1576,6 +1576,7 @@ data HsMatchContext p | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration + | LazyPatCtx -- ^An irrefutable pattern {- Note [mc_fun field of FunRhs] ===================================== testsuite/tests/ado/T22483.stderr ===================================== @@ -2,7 +2,7 @@ T22483.hs:1:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: main :: IO () -T22483.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] +T22483.hs:4:4: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] Pattern match(es) are non-exhaustive - In a pattern binding: + In an irrefutable pattern: Patterns of type ‘Maybe ()’ not matched: Nothing ===================================== testsuite/tests/deSugar/should_run/dsrun008.stderr ===================================== @@ -1,2 +1,2 @@ -dsrun008: dsrun008.hs:2:15-42: Non-exhaustive patterns in (2, x) +dsrun008: dsrun008.hs:2:32-36: Non-exhaustive patterns in (2, x) ===================================== testsuite/tests/pmcheck/should_compile/T24234.hs ===================================== @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -W #-} + +module T24234 where + +foo :: [()] -> () +foo ~(a:_) = a +foo _ = () ===================================== testsuite/tests/pmcheck/should_compile/T24234.stderr ===================================== @@ -0,0 +1,8 @@ + +T24234.hs:6:6: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] + Pattern match(es) are non-exhaustive + In an irrefutable pattern: Patterns of type ‘[()]’ not matched: [] + +T24234.hs:7:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘foo’: foo _ = ... ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -120,6 +120,7 @@ test('T19271', [], compile, [overlapping_incomplete]) test('T21761', [], compile, [overlapping_incomplete]) test('T22964', [], compile, [overlapping_incomplete]) test('T23445', [], compile, [overlapping_incomplete]) +test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns']) # Series (inspired) by Luke Maranget @@ -166,4 +167,4 @@ test('EmptyCase009', [], compile, [overlapping_incomplete]) test('EmptyCase010', [], compile, [overlapping_incomplete]) test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors']) test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors']) -test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) \ No newline at end of file +test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f1cb4c94469a5f93cbebffe8519dfe77b2910cb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9f1cb4c94469a5f93cbebffe8519dfe77b2910cb 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 Dec 5 12:20:29 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 05 Dec 2023 07:20:29 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/24196 Message-ID: <656f158d95595_319fc17fd9d37849745d@gitlab.mail> Zubin pushed new branch wip/24196 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24196 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 Dec 5 14:46:18 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Tue, 05 Dec 2023 09:46:18 -0500 Subject: [Git][ghc/ghc][wip/T23862] Cpr: Turn an assertion into a check to deal with some dead code (#23862) Message-ID: <656f37ba4ddc2_319fc183563c44517015@gitlab.mail> Sebastian Graf pushed to branch wip/T23862 at Glasgow Haskell Compiler / GHC Commits: 7fe95d45 by Sebastian Graf at 2023-12-05T15:46:08+01: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. - - - - - 4 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - + testsuite/tests/cpranal/should_compile/T23862.hs - + testsuite/tests/cpranal/should_compile/T23862.stderr - testsuite/tests/cpranal/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -270,11 +270,11 @@ cprAnalAlt cprAnalAlt env scrut_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where + ids = filter isId bndrs env_alt | DataAlt dc <- con - , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty - , assert (arity == 0 ) True + , arity == 0 -- See Note [Dead code may contain type confusions] = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr @@ -283,7 +283,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) | let sigs = zipWith (mkCprSig . idArity) ids field_cprs -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) | otherwise - = env + = extendSigEnvAllSame env ids topCprSig (rhs_ty, rhs') = cprAnal env_alt rhs -- @@ -430,6 +430,43 @@ cprFix orig_env orig_pairs (id', rhs', env') = cprAnalBind env id rhs {- +Note [Dead code may contain type confusions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In T23862, we have a nested case match that looks like this + + data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + data family Result (check :: Bool) a + data instance Result True a = CheckedResult a + newtype instance Result True a = UncheckedResult a + + case m () of Checked co1 -> + case m () of Unchecked co2 -> + case ((\_ -> True) + |> .. UncheckedResult .. + |> sym co2 + |> co1) :: Result True (Bool -> Bool) of + CheckedResult f -> CheckedResult (f True) + +Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` +cases are apart. +However, both constructors introduce mutually contradictory coercions `co1` and +`co2` along which GHC generates a type confusion: + + 1. (\_ -> True) :: Bool -> Bool + 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) + 3. |> ... sym co1 ... :: Result check (Bool -> Bool) + 4. |> ... co2 ... :: Result True (Bool -> Bool) + +Note that we started with a function, injected into `Result` via a newtype +instance and then match on it with a datatype instance. + +We have to handle this case gracefully in `cprAnalAlt`, where for the innermost +case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that +abstracts the function `(\_ -> True)` with arity 1. +In this case, don't pretend we know anything about the fields of `CheckedResult`! + Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: ===================================== testsuite/tests/cpranal/should_compile/T23862.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} + +module T23862 where + +data family Result (check :: Bool) a +data instance Result True a = CheckedResult a +newtype instance Result False a = UncheckedResult a + +data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + +app :: (() -> CheckSingleton check) -> Result check Bool +app m = case (m (), m ()) of + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\_ -> True) + -> CheckedResult (x True) ===================================== testsuite/tests/cpranal/should_compile/T23862.stderr ===================================== @@ -0,0 +1,18 @@ + +T23862.hs:17:12: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)] + • Inaccessible code in + a pattern with constructor: Unchecked :: CheckSingleton False, + in a case alternative + Couldn't match type ‘True’ with ‘False’ + • In the pattern: Unchecked + In the pattern: (Checked, Unchecked) + In a case alternative: + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\ _ -> True) + -> CheckedResult (x True) + +T23862.hs:18:6: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In a case alternative: + (Checked, Unchecked) | CheckedResult x <- UncheckedResult + (\ _ -> True) -> ... ===================================== testsuite/tests/cpranal/should_compile/all.T ===================================== @@ -22,3 +22,5 @@ test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsu test('T18824', [ grep_errmsg(r'JoinId[^\n]*Cpr') ], compile, ['-ddump-exitify -dppr-cols=1000 -dsuppress-uniques']) test('T20539', [], compile, ['']) # simply should not crash + +test('T23862', [], compile, ['']) # simply should not crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe95d451000bf3a4e8864b50c10ad26dfc917e9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7fe95d451000bf3a4e8864b50c10ad26dfc917e9 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 Dec 5 14:51:36 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Tue, 05 Dec 2023 09:51:36 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24190 Message-ID: <656f38f815d7a_319fc18388f8285194e1@gitlab.mail> Oleg Grenrus pushed new branch wip/T24190 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24190 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 Dec 5 17:12:10 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Tue, 05 Dec 2023 12:12:10 -0500 Subject: [Git][ghc/ghc][wip/T24190] Allow untyped brackets in typed splices and vice versa. Message-ID: <656f59eab5b95_319fc18724e30c575312@gitlab.mail> Oleg Grenrus pushed to branch wip/T24190 at Glasgow Haskell Compiler / GHC Commits: aaece53d by Oleg Grenrus at 2023-12-05T19:12:02+02: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. - - - - - 6 changed files: - compiler/GHC/Rename/Splice.hs - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -93,9 +93,7 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +121,7 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -598,3 +598,4 @@ test('T23968', normal, compile_and_run, ['']) test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aaece53d655dfbfdd6bcf76eaa3b9007b7553b76 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aaece53d655dfbfdd6bcf76eaa3b9007b7553b76 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 Dec 5 18:21:07 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Tue, 05 Dec 2023 13:21:07 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: New location for HsLet tokens Message-ID: <656f6a1311aab_2f7fd3133c88198e4@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 7007b26c by Alan Zimmerman at 2023-12-05T18:20:43+00:00 EPA: New location for HsLet tokens First example rework of using a tuple in the extension field for GhcPs for token locations, and keeping the EpAnn field in the surrounding XRec. Addresses #23447 - - - - - 20 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/perf/compiler/hard_hole_fits.hs - testsuite/tests/perf/compiler/hard_hole_fits.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -75,6 +75,7 @@ import qualified Data.Kind import Data.Maybe (isJust) import Data.Foldable ( toList ) import Data.List.NonEmpty (NonEmpty) +import Language.Haskell.Syntax.Concrete (LHsToken) {- ********************************************************************* * * @@ -289,7 +290,7 @@ type instance XMultiIf GhcPs = EpAnn [AddEpAnn] type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet GhcPs = EpAnnCO +type instance XLet GhcPs = (LHsToken "let" GhcPs, LHsToken "in" GhcPs) type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField @@ -644,11 +645,11 @@ ppr_expr (HsMultiIf _ alts) ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... -ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _))) +ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lexpr expr] -ppr_expr (HsLet _ _ binds _ expr) +ppr_expr (HsLet _ binds expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -118,7 +118,7 @@ hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t hsExprType (HsMultiIf ty _) = ty -hsExprType (HsLet _ _ _ _ body) = lhsExprType body +hsExprType (HsLet _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -424,7 +424,7 @@ dsExpr (HsCase ctxt discrim matches) -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -dsExpr (HsLet _ _ binds _ body) = do +dsExpr (HsLet _ binds body) = do body' <- dsLExpr body dsLocalBinds binds body' ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1569,10 +1569,10 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ _ bs _ e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } +repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet repE e@(HsDo _ ctxt (L _ sts)) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -528,11 +528,11 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x tkLet binds tkIn e) = +addTickHsExpr (HsLet x binds e) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. e' <- addTickLHsExprLetBody e - return (HsLet x tkLet binds' tkIn e') + return (HsLet x binds' e') addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) ; return (HsDo srcloc cxt (L l stmts')) } ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -739,7 +739,7 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where HsPar _ _ e _ -> computeLType e ExplicitTuple{} -> Nothing HsIf _ _ t f -> computeLType t <|> computeLType f - HsLet _ _ _ _ body -> computeLType body + HsLet _ _ body -> computeLType body RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e @@ -1217,7 +1217,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where HsMultiIf _ grhss -> [ toHie grhss ] - HsLet _ _ binds _ expr -> + HsLet _ binds expr -> [ toHie $ RS (mkScope expr) binds , toHie expr ] ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -105,6 +105,7 @@ import GHC.Hs.DocString import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict +import Language.Haskell.Syntax.Concrete (HsToken(..)) {- Note [exact print annotations] @@ -1342,6 +1343,9 @@ instance NoAnn AnnPragma where instance NoAnn AnnParen where noAnn = AnnParen AnnParens noAnn noAnn +instance NoAnn (GenLocated TokenLocation (HsToken s)) where + noAnn = L NoTokenLoc HsTok + -- --------------------------------------------------------------------- instance (Outputable a) => Outputable (EpAnn a) where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1792,7 +1792,7 @@ instance DisambECP (HsExpr GhcPs) where return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs) mkHsLetPV l tkLet bs tkIn c = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l e1 op e2 = do ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -425,10 +425,10 @@ rnExpr (HsCase _ expr matches) ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ tkLet binds tkIn expr) +rnExpr (HsLet _ binds expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) } + ; return (HsLet noExtField binds' expr', fvExpr) } rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts1, _), fvs1) <- ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -347,10 +347,10 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty ************************************************************************ -} -tcExpr (HsLet x tkLet binds tkIn expr) res_ty +tcExpr (HsLet x binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x tkLet binds' tkIn expr') } + ; return (HsLet x binds' expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. @@ -1303,7 +1303,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty -- STEP 2 (b): desugar to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn - ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) + ds_expr = HsLet noExtField let_binds (L gen case_expr) case_expr :: HsExpr GhcRn case_expr = HsCase RecUpd record_expr ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -726,7 +726,7 @@ exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = RecordUpdOrigin ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1011,10 +1011,10 @@ zonkExpr (HsMultiIf ty alts) do { expr' <- zonkLExpr expr ; return $ GRHS x guard' expr' } -zonkExpr (HsLet x tkLet binds tkIn expr) +zonkExpr (HsLet x binds expr) = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> do { new_expr <- zonkLExpr expr - ; return (HsLet x tkLet new_binds tkIn new_expr) } + ; return (HsLet x new_binds new_expr) } zonkExpr (HsDo ty do_or_lc (L l stmts)) = do new_stmts <- don'tBind $ zonkStmts zonkLExpr stmts ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1079,7 +1079,7 @@ cvtl e = wrapLA (cvt e) | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf noAnn alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds - ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} + ; e' <- cvtl e; return $ HsLet noAnn ds' e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' } ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -429,9 +429,7 @@ data HsExpr p -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsLet (XLet p) - !(LHsToken "let" p) (HsLocalBinds p) - !(LHsToken "in" p) (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1951,15 +1951,15 @@ (EpaComments [])) (HsLet - (EpAnn - (EpaSpan { DumpSemis.hs:34:10-35 }) - (NoEpAnns) - (EpaComments - [])) - (L - (TokenLoc - (EpaSpan { DumpSemis.hs:34:10-12 })) - (HsTok)) + ((,) + (L + (TokenLoc + (EpaSpan { DumpSemis.hs:34:10-12 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { DumpSemis.hs:34:32-33 })) + (HsTok))) (HsValBinds (EpAnn (EpaSpan { DumpSemis.hs:34:13-31 }) @@ -2186,10 +2186,6 @@ (EmptyLocalBinds (NoExtField)))))]))))]} [])) - (L - (TokenLoc - (EpaSpan { DumpSemis.hs:34:32-33 })) - (HsTok)) (L (EpAnn (EpaSpan { DumpSemis.hs:34:35 }) ===================================== testsuite/tests/perf/compiler/hard_hole_fits.hs ===================================== @@ -30,7 +30,7 @@ testMe (ExplicitSum xes n i gl) = _ testMe (HsCase xc gl mg) = _ testMe (HsIf xi m_se gl gl' ) = _ testMe (HsMultiIf xmi gls) = _ -testMe (HsLet xl tkLet gl tkIn gl') = _ +testMe (HsLet xl gl gl') = _ testMe (HsDo xd hsc gl) = _ testMe (ExplicitList xel m_se) = _ testMe (RecordCon xrc gl hrf) = _ ===================================== testsuite/tests/perf/compiler/hard_hole_fits.stderr ===================================== @@ -383,17 +383,12 @@ hard_hole_fits.hs:32:30: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20 (and originally defined in ‘GHC.Enum’)) -hard_hole_fits.hs:33:39: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] +hard_hole_fits.hs:33:28: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int - • In an equation for ‘testMe’: - testMe (HsLet xl tkLet gl tkIn gl') = _ + • In an equation for ‘testMe’: testMe (HsLet xl gl gl') = _ • Relevant bindings include - gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:33:32) - tkIn :: Language.Haskell.Syntax.Concrete.LHsToken "in" GhcPs - (bound at hard_hole_fits.hs:33:27) + gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:33:21) gl :: Language.Haskell.Syntax.Binds.HsLocalBinds GhcPs - (bound at hard_hole_fits.hs:33:24) - tkLet :: Language.Haskell.Syntax.Concrete.LHsToken "let" GhcPs (bound at hard_hole_fits.hs:33:18) xl :: Language.Haskell.Syntax.Extension.XLet GhcPs (bound at hard_hole_fits.hs:33:15) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2861,7 +2861,7 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsCase an _ _) = fromAnn an getAnnotationEntry (HsIf an _ _ _) = fromAnn an getAnnotationEntry (HsMultiIf an _) = fromAnn an - getAnnotationEntry (HsLet an _ _ _ _) = fromAnn an + getAnnotationEntry (HsLet _ _ _) = NoEntryVal getAnnotationEntry (HsDo an _ _) = fromAnn an getAnnotationEntry (ExplicitList an _) = fromAnn an getAnnotationEntry (RecordCon an _ _) = fromAnn an @@ -2899,7 +2899,7 @@ instance ExactPrint (HsExpr GhcPs) where setAnnotationAnchor (HsCase an a b) anc ts cs = (HsCase (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (HsIf an a b c) anc ts cs = (HsIf (setAnchorEpa an anc ts cs) a b c) setAnnotationAnchor (HsMultiIf an a) anc ts cs = (HsMultiIf (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsLet an a b c d) anc ts cs = (HsLet (setAnchorEpa an anc ts cs) a b c d) + setAnnotationAnchor a@(HsLet{}) _ _ _s = a setAnnotationAnchor (HsDo an a b) anc ts cs = (HsDo (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (ExplicitList an a) anc ts cs = (ExplicitList (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (RecordCon an a b) anc ts cs = (RecordCon (setAnchorEpa an anc ts cs) a b) @@ -3055,7 +3055,7 @@ instance ExactPrint (HsExpr GhcPs) where an2 <- markEpAnnL an1 lidl AnnCloseC -- optional return (HsMultiIf an2 mg') - exact (HsLet an tkLet binds tkIn e) = do + exact (HsLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too tkLet' <- markToken tkLet debugM $ "HSlet:binds coming" @@ -3064,7 +3064,7 @@ instance ExactPrint (HsExpr GhcPs) where tkIn' <- markToken tkIn debugM $ "HSlet:expr coming" e' <- markAnnotated e - return (HsLet an tkLet' binds' tkIn' e') + return (HsLet (tkLet',tkIn') binds' e') exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" ===================================== utils/check-exact/Main.hs ===================================== @@ -444,7 +444,7 @@ changeLetIn1 _libdir parsed = return (everywhere (mkT replace) parsed) where replace :: HsExpr GhcPs -> HsExpr GhcPs - replace (HsLet an tkLet localDecls _ expr) + replace (HsLet (tkLet, _) localDecls expr) = let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls [l2,_l1] = map wrapDecl $ bagToList bagDecls @@ -453,8 +453,8 @@ changeLetIn1 _libdir parsed a = EpAnn (EpaDelta (SameLine 1) []) noAnn emptyComments expr' = L a e tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok - in (HsLet an tkLet - (HsValBinds x (ValBinds xv bagDecls' sigs)) tkIn' expr') + in (HsLet (tkLet, tkIn') + (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') replace x = x @@ -802,13 +802,13 @@ rmDecl5 _libdir lp = do doRmDecl = do let go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) - go (HsLet a tkLet lb tkIn expr) = do + go (HsLet (tkLet, tkIn) lb expr) = do let decs = hsDeclsLocalBinds lb let hdecs : _ = decs let dec = last decs _ <- transferEntryDP hdecs dec lb' <- replaceDeclsValbinds WithoutWhere lb [dec] - return (HsLet a tkLet lb' tkIn expr) + return (HsLet (tkLet, tkIn) lb' expr) go x = return x everywhereM (mkM go) lp ===================================== utils/check-exact/Transform.hs ===================================== @@ -875,10 +875,10 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where -- --------------------------------------------------------------------- instance HasDecls (LocatedA (HsExpr GhcPs)) where - hsDecls (L _ (HsLet _ _ decls _ _ex)) = return $ hsDeclsLocalBinds decls - hsDecls _ = return [] + hsDecls (L _ (HsLet _ decls _ex)) = return $ hsDeclsLocalBinds decls + hsDecls _ = return [] - replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls + replaceDecls (L ll (HsLet (tkLet, tkIn) binds ex)) newDecls = do logTr "replaceDecls HsLet" let lastAnc = realSrcSpan $ spanHsLocaLBinds binds @@ -901,7 +901,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where , newDecls'') (_,_) -> (tkLet, tkIn, ex, newDecls) binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' - return (L ll (HsLet x tkLet' binds' tkIn' ex')) + return (L ll (HsLet (tkLet', tkIn') binds' ex')) -- TODO: does this make sense? Especially as no hsDecls for HsPar replaceDecls (L l (HsPar x lpar e rpar)) newDecls View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7007b26c5c1b3b37eeb92a15a538383a197902ba -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7007b26c5c1b3b37eeb92a15a538383a197902ba 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 Dec 5 18:28:51 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 05 Dec 2023 13:28:51 -0500 Subject: [Git][ghc/ghc][wip/int-index/forall-keyword] 286 commits: Profiling: Properly escape characters when using `-pj`. Message-ID: <656f6be33628a_2f7fd33c814c20212@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/forall-keyword 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. - - - - - 4cb4ddb5 by Vladislav Zavialov at 2023-12-05T21:28:12+03: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. - - - - - 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/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 - compiler/GHC/CmmToAsm/Ppr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db825b400080b6755be61db8a5cf46c2aad3af9b...4cb4ddb5c72684431d0f570c71f81224bd7065b4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/db825b400080b6755be61db8a5cf46c2aad3af9b...4cb4ddb5c72684431d0f570c71f81224bd7065b4 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 Dec 5 22:23:55 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Tue, 05 Dec 2023 17:23:55 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Introduce EpToken as simpler version of HsToken Message-ID: <656fa2fbdbc19_2f7fd351ef5f03356@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 41e67a62 by Alan Zimmerman at 2023-12-05T22:21:15+00:00 EPA: Introduce EpToken as simpler version of HsToken This puts an EpaLocation inside, and does away with GenLocated. Initially used only for HsCmdLet and HsLet - - - - - 15 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/parser/should_compile/DumpSemis.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -75,7 +75,6 @@ import qualified Data.Kind import Data.Maybe (isJust) import Data.Foldable ( toList ) import Data.List.NonEmpty (NonEmpty) -import Language.Haskell.Syntax.Concrete (LHsToken) {- ********************************************************************* * * @@ -290,7 +289,7 @@ type instance XMultiIf GhcPs = EpAnn [AddEpAnn] type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet GhcPs = (LHsToken "let" GhcPs, LHsToken "in" GhcPs) +type instance XLet GhcPs = (EpToken "let", EpToken "in") type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField @@ -1135,7 +1134,7 @@ type instance XCmdIf GhcPs = EpAnn AnnsIf type instance XCmdIf GhcRn = NoExtField type instance XCmdIf GhcTc = NoExtField -type instance XCmdLet GhcPs = EpAnnCO +type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField @@ -1261,11 +1260,11 @@ ppr_cmd (HsCmdIf _ _ e ct ce) nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {}))) +ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet _ _ binds _ cmd) +ppr_cmd (HsCmdLet _ binds cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] ===================================== compiler/GHC/HsToCore/Arrows.hs ===================================== @@ -591,7 +591,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds at binds _ body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds at binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -836,11 +836,11 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x tkLet binds tkIn c) = +addTickHsCmd (HsCmdLet x binds c) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. c' <- addTickLHsCmd c - return (HsCmdLet x tkLet binds' tkIn c') + return (HsCmdLet x binds' c') addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) ; return (HsCmdDo srcloc (L l stmts')) } ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1512,7 +1512,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where , toHie b , toHie c ] - HsCmdLet _ _ binds _ cmd' -> + HsCmdLet _ binds cmd' -> [ toHie $ RS (mkScope cmd') binds , toHie cmd' ] ===================================== compiler/GHC/Parser.y ===================================== @@ -2869,7 +2869,7 @@ aexp :: { ECP } mkHsNegAppPV (comb2 $1 $>) $2 [mj AnnMinus $1] } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> - mkHsLetPV (comb2 $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 } + mkHsLetPV (comb2 $1 $>) (epTok $1) (unLoc $2) (epTok $3) $4 } | '\\' apats '->' exp { ECP $ unECP $4 >>= \ $4 -> @@ -4470,6 +4470,9 @@ listAsAnchorM (L l _:_) = RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll _ -> Nothing +epTok :: Located Token -> EpToken tok +epTok (L l _) = EpTok (EpaSpan l) + hsTok :: Located Token -> LHsToken tok GhcPs hsTok (L l _) = L (mkTokenLocation l) HsTok ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -1,11 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Parser.Annotation ( -- * Core Exact Print Annotation types AnnKeywordId(..), + EpToken(..), EpUniToken(..), EpaComment(..), EpaCommentTok(..), IsUnicodeSyntax(..), unicodeAnn, @@ -99,6 +103,7 @@ import Data.Function (on) import Data.List (sortBy, foldl1') import Data.Semigroup import GHC.Data.FastString +import GHC.TypeLits (Symbol, KnownSymbol) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString @@ -357,6 +362,21 @@ data HasE = HasE | NoE -- --------------------------------------------------------------------- +data EpToken (tok :: Symbol) + = NoEpTok + | EpTok !EpaLocation + +data EpUniToken (tok :: Symbol) (utok :: Symbol) + = NoEpUniTok + | EpNormalTok !EpaLocation + | EpUnicodeTok !EpaLocation + +deriving instance Eq (EpToken tok) +deriving instance KnownSymbol tok => Data (EpToken tok) +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok) + +-- --------------------------------------------------------------------- + data EpaComment = EpaComment { ac_tok :: EpaCommentTok @@ -1346,6 +1366,12 @@ instance NoAnn AnnParen where instance NoAnn (GenLocated TokenLocation (HsToken s)) where noAnn = L NoTokenLoc HsTok +instance NoAnn (EpToken s) where + noAnn = NoEpTok + +instance NoAnn (EpUniToken s t) where + noAnn = NoEpUniTok + -- --------------------------------------------------------------------- instance (Outputable a) => Outputable (EpAnn a) where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1556,9 +1556,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate "let ... in ..." mkHsLetPV :: SrcSpan - -> LHsToken "let" GhcPs + -> EpToken "let" -> HsLocalBinds GhcPs - -> LHsToken "in" GhcPs + -> EpToken "in" -> LocatedA b -> PV (LocatedA b) -- | Infix operator representation @@ -1708,7 +1708,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsLetPV l tkLet bs tkIn e = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -905,10 +905,10 @@ rnCmd (HsCmdIf _ _ p b1 b2) ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ tkLet binds tkIn cmd) +rnCmd (HsCmdLet _ binds cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) } + ; return (HsCmdLet noExtField binds' cmd', fvExpr) } rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <- @@ -936,7 +936,7 @@ methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c ===================================== compiler/GHC/Tc/Gen/Arrow.hs ===================================== @@ -154,11 +154,11 @@ tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x lpar cmd' rpar) } -tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan (locA body_loc) $ tc_cmd env body res_ty - ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) } + ; return (HsCmdLet x binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1165,10 +1165,10 @@ zonkCmd (HsCmdIf x eCond ePred cThen cElse) ; new_cElse <- zonkLCmd cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd (HsCmdLet x tkLet binds tkIn cmd) +zonkCmd (HsCmdLet x binds cmd) = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> do new_cmd <- zonkLCmd cmd - return (HsCmdLet x tkLet new_binds tkIn new_cmd) + return (HsCmdLet x new_binds new_cmd) zonkCmd (HsCmdDo ty (L l stmts)) = do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -889,9 +889,7 @@ data HsCmd id -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsCmdLet (XCmdLet id) - !(LHsToken "let" id) (HsLocalBinds id) -- let(rec) - !(LHsToken "in" id) (LHsCmd id) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1952,14 +1952,10 @@ [])) (HsLet ((,) - (L - (TokenLoc - (EpaSpan { DumpSemis.hs:34:10-12 })) - (HsTok)) - (L - (TokenLoc - (EpaSpan { DumpSemis.hs:34:32-33 })) - (HsTok))) + (EpTok + (EpaSpan { DumpSemis.hs:34:10-12 })) + (EpTok + (EpaSpan { DumpSemis.hs:34:32-33 }))) (HsValBinds (EpAnn (EpaSpan { DumpSemis.hs:34:13-31 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -793,6 +793,13 @@ markLToken (L (RealSrcSpan aa mb) t) = do _ -> return (L (RealSrcSpan aa mb ) t) markLToken (L lt t) = return (L lt t) +markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => EpToken tok -> EP w m (EpToken tok) +markEpToken NoEpTok = return NoEpTok +markEpToken (EpTok aa) = do + aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) + return (EpTok aa') + markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) markToken (L NoTokenLoc t) = return (L NoTokenLoc t) @@ -3057,12 +3064,9 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markToken tkLet - debugM $ "HSlet:binds coming" + tkLet' <- markEpToken tkLet binds' <- setLayoutBoth $ markAnnotated binds - debugM $ "HSlet:binds done" - tkIn' <- markToken tkIn - debugM $ "HSlet:expr coming" + tkIn' <- markEpToken tkIn e' <- markAnnotated e return (HsLet (tkLet',tkIn') binds' e') @@ -3427,7 +3431,7 @@ instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdCase an _ _) = fromAnn an getAnnotationEntry (HsCmdLam an _ _) = fromAnn an getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdLet _ _ _) = NoEntryVal getAnnotationEntry (HsCmdDo an _) = fromAnn an setAnnotationAnchor (HsCmdArrApp an a b c d) anc ts cs = (HsCmdArrApp (setAnchorEpa an anc ts cs) a b c d) @@ -3437,7 +3441,7 @@ instance ExactPrint (HsCmd GhcPs) where setAnnotationAnchor (HsCmdPar an a b c) anc ts cs = (HsCmdPar (setAnchorEpa an anc ts cs) a b c) setAnnotationAnchor (HsCmdCase an a b) anc ts cs = (HsCmdCase (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (HsCmdIf an a b c d) anc ts cs = (HsCmdIf (setAnchorEpa an anc ts cs) a b c d) - setAnnotationAnchor (HsCmdLet an a b c d) anc ts cs = (HsCmdLet (setAnchorEpa an anc ts cs) a b c d) + setAnnotationAnchor (HsCmdLet an a b) _ _ _s = (HsCmdLet an a b) setAnnotationAnchor (HsCmdDo an a) anc ts cs = (HsCmdDo (setAnchorEpa an anc ts cs) a) exact (HsCmdArrApp an arr arg o isRightToLeft) = do @@ -3512,13 +3516,13 @@ instance ExactPrint (HsCmd GhcPs) where e3' <- markAnnotated e3 return (HsCmdIf an4 a e1' e2' e3') - exact (HsCmdLet an tkLet binds tkIn e) = do + exact (HsCmdLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markToken tkLet + tkLet' <- markEpToken tkLet binds' <- setLayoutBoth $ markAnnotated binds - tkIn' <- markToken tkIn + tkIn' <- markEpToken tkIn e' <- markAnnotated e - return (HsCmdLet an tkLet' binds' tkIn' e') + return (HsCmdLet (tkLet', tkIn') binds' e') exact (HsCmdDo an es) = do debugM $ "HsCmdDo" ===================================== utils/check-exact/Main.hs ===================================== @@ -452,7 +452,7 @@ changeLetIn1 _libdir parsed (L _ e) = expr a = EpAnn (EpaDelta (SameLine 1) []) noAnn emptyComments expr' = L a e - tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok + tkIn' = EpTok (EpaDelta (DifferentLine 1 0) []) in (HsLet (tkLet, tkIn') (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') ===================================== utils/check-exact/Transform.hs ===================================== @@ -884,7 +884,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where let lastAnc = realSrcSpan $ spanHsLocaLBinds binds -- TODO: may be an intervening comment, take account for lastAnc let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of - (L (TokenLoc l) ls, L (TokenLoc i) is) -> + (EpTok l, EpTok i) -> let off = case l of (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r @@ -895,8 +895,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where newDecls'' = case newDecls of [] -> newDecls (d:ds) -> setEntryDPDecl d (SameLine 0) : ds - in ( L (TokenLoc l) ls - , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is + in ( EpTok l + , EpTok (addEpaLocationDelta off lastAnc i) , ex'' , newDecls'') (_,_) -> (tkLet, tkIn, ex, newDecls) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41e67a6217d2cb7790509612f821fedc803fcf63 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41e67a6217d2cb7790509612f821fedc803fcf63 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 Dec 6 04:38:47 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 05 Dec 2023 23:38:47 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/multilayerth-darwin Message-ID: <656ffad7e623a_2f7fd3e68b17850892@gitlab.mail> Zubin pushed new branch wip/multilayerth-darwin at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/multilayerth-darwin 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 Dec 6 07:51:22 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 06 Dec 2023 02:51:22 -0500 Subject: [Git][ghc/ghc][wip/24107] 13 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <657027fac9f7b_2f7fd312e14ee056366@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - dae9954a by Zubin Duggal at 2023-12-06T13:21:07+05:30 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 - - - - - c81501c1 by Zubin Duggal at 2023-12-06T13:21:07+05:30 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 - - - - - acd231c1 by Zubin Duggal at 2023-12-06T13:21:07+05:30 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 - - - - - 58837bfa by Zubin Duggal at 2023-12-06T13:21:07+05:30 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 - - - - - 15 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Name/Reader.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - testsuite/driver/testlib.py - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T - − testsuite/tests/perf/size/Makefile - testsuite/tests/perf/size/all.T Changes: ===================================== compiler/GHC/Data/Bag.hs ===================================== @@ -40,6 +40,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq infixr 3 `consBag` infixl 3 `snocBag` @@ -51,6 +52,12 @@ data Bag a | ListBag (NonEmpty a) deriving (Foldable, Functor, Traversable) +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a + emptyBag :: Bag a emptyBag = EmptyBag ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -771,6 +771,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env + hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env @@ -780,7 +781,6 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do worker_limit <- liftIO $ mkWorkerLimit dflags - setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -934,11 +934,11 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- +-- Also forces the bag in gre_imp. -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs + strictMapOccEnv (strictMap (\ gre -> rnf (gre_imp gre) `seq` gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. @@ -1916,25 +1916,28 @@ instance Semigroup ShadowedGREs where -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1945,8 +1948,8 @@ data ImpItemSpec -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -398,10 +398,12 @@ partition p = List.partition p . toList -- | The 'group' function takes a stream and returns a list of -- streams such that flattening the resulting list is equal to the -- argument. Moreover, each stream in the resulting list --- contains only equal elements. For example, in list notation: +-- contains only equal elements, and consecutive equal elements +-- of the input end up in the same stream of the output list. +-- For example, in list notation: -- --- > 'group' $ 'cycle' "Mississippi" --- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +-- >>> group "Mississippi" +-- ["M", "i", "ss", "i", "ss", "i", "pp", "i"] group :: (Foldable f, Eq a) => f a -> [NonEmpty a] group = groupBy (==) ===================================== libraries/base/src/Data/OldList.hs ===================================== @@ -1360,8 +1360,9 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- | The 'group' function takes a list and returns a list of lists such -- that the concatenation of the result is equal to the argument. Moreover, --- each sublist in the result is non-empty and all elements are equal --- to the first one. +-- each sublist in the result is non-empty, all elements are equal to the +-- first one, and consecutive equal elements of the input end up in the +-- same element of the output list. -- -- 'group' is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. ===================================== testsuite/driver/testlib.py ===================================== @@ -607,6 +607,19 @@ def _extra_files(name, opts, files): def collect_size ( deviation, path ): return collect_generic_stat ( 'size', deviation, lambda way: os.path.getsize(in_testdir(path)) ) +def get_dir_size(path): + total = 0 + with os.scandir(path) as it: + for entry in it: + if entry.is_file(): + total += entry.stat().st_size + elif entry.is_dir(): + total += get_dir_size(entry.path) + return total + +def collect_size_dir ( deviation, path ): + return collect_generic_stat ( 'size', deviation, lambda way: get_dir_size(path) ) + # Read a number from a specific file def stat_from_file ( metric, deviation, path ): def read_file (way): @@ -1810,7 +1823,6 @@ def metric_dict(name, way, metric, value) -> PerfStat: def check_generic_stats(name, way, get_stats): for (metric, gen_stat) in get_stats.items(): res = report_stats(name, way, metric, gen_stat) - print(res) if badResult(res): return res return passed() ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) ===================================== testsuite/tests/ghci/T23405/T23405.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23405 (test) where + +import Language.Haskell.TH + +test :: IO () +test = do + let s = $(getDoc (DeclDoc ''Double) >>= \doc -> [|doc|]) + print (s `seq` ()) + + ===================================== testsuite/tests/ghci/T23405/T23405.script ===================================== @@ -0,0 +1,3 @@ +:load T23405.hs +:! echo "-- an extra comment so that the hash changes" >> T18262.hs +:reload ===================================== testsuite/tests/ghci/T23405/all.T ===================================== @@ -0,0 +1 @@ +test('T23405', [extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -391,6 +391,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefs'), + extra_files(['genMultiLayerModulesDefs']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), ===================================== testsuite/tests/perf/size/Makefile deleted ===================================== @@ -1,7 +0,0 @@ -TOP=../../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -libdir_size: - du -s `$(TEST_HC) --print-libdir` | cut -f1 > SIZE - ===================================== testsuite/tests/perf/size/all.T ===================================== @@ -1,3 +1,3 @@ test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, ['']) -test('libdir',[stat_from_file('size', 10, 'SIZE')], makefile_test, ['libdir_size'] ) +test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42c4620d9df1eaceb4b8ebeeba8a5fa22f44f254...58837bfac616b913ed45f5402d2ad9e90cdada65 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/42c4620d9df1eaceb4b8ebeeba8a5fa22f44f254...58837bfac616b913ed45f5402d2ad9e90cdada65 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 Dec 6 10:42:11 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 05:42:11 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 18 commits: docs(NonEmpty/group): Remove incorrect haddock link quotes in code block Message-ID: <6570500353533_2f7fd316b89e6065236@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 419c1a9e by Claudio Bley at 2023-12-06T05:41:47-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 - - - - - 5a9f9003 by Vladislav Zavialov at 2023-12-06T05:41:48-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 - - - - - 348a73ca by Sebastian Graf at 2023-12-06T05:41:48-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". - - - - - 02b42b31 by Matthew Pickering at 2023-12-06T05:41:49-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 - - - - - 4cd5d7bc by Matthew Pickering at 2023-12-06T05:41:49-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 - - - - - 7888f0e5 by Zubin Duggal at 2023-12-06T05:41:49-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 - - - - - b6117c76 by Sylvain Henry at 2023-12-06T05:42:00-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 - - - - - 49a3e2ad by Sebastian Graf at 2023-12-06T05:42:01-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. - - - - - 59ecf52b by Zubin Duggal at 2023-12-06T05:42:01-05:00 testsuite: Allow MultiLayerModulesTH_Make and MultiLayerModulesTH_OneShot to deviate by up to 5% The amount of allocations seem to be environment dependent on Darwin This is likely due to extra allocations from looking up and normalising LD_LIBRARY_PATH and similar in loadPackage See https://gitlab.haskell.org/ghc/ghc/-/issues/24177 - - - - - 30 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Warnings.hs - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/Data/OldList.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - testsuite/driver/testlib.py - testsuite/tests/ado/T22483.stderr - + testsuite/tests/core-to-stg/T14895.hs - + testsuite/tests/core-to-stg/T14895.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91d1a7dde6aeac3bf022341205cc08de4ce6cfe9...59ecf52b0ce30d680ebb9d411a313001f4d4aadd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91d1a7dde6aeac3bf022341205cc08de4ce6cfe9...59ecf52b0ce30d680ebb9d411a313001f4d4aadd 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 Dec 6 11:47:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 06 Dec 2023 06:47:27 -0500 Subject: [Git][ghc/ghc][wip/23944] driver: Only run a dynamic-too pipeline if object files are going to be generated Message-ID: <65705f4f93c0c_2f7fd318740320783c4@gitlab.mail> Zubin pushed to branch wip/23944 at Glasgow Haskell Compiler / GHC Commits: 2b69d69e by Zubin Duggal at 2023-12-06T17:17:20+05:30 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. - - - - - 1 changed file: - compiler/GHC/Driver/Pipeline.hs Changes: ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -788,7 +788,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result - when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do + -- Only run dynamic-too if the backend generates object files + -- See Note [Writing interface files] + -- If we are writing a simple interface (not . backendWritesFiles), then + -- hscMaybeWriteIface in the regular pipeline will write both the hi and + -- dyn_hi files. This way we can avoid running the pipeline twice and + -- generating a duplicate linkable. + -- We must not run the backend a second time with `dynamicNow` enable because + -- all the work has already been done in the first pipeline. + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result return res View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b69d69e56a8e6e1456f29bdda357ee14e3bc77c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b69d69e56a8e6e1456f29bdda357ee14e3bc77c 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 Dec 6 13:12:44 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 08:12:44 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Only exit ghci in -e mode when :add command fails Message-ID: <6570734cdc5e0_2f7fd31a8ce294111883@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 1e90822e by Claudio Bley at 2023-12-06T08:11:54-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 - - - - - 3d244526 by Vladislav Zavialov at 2023-12-06T08:11:55-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 - - - - - 91e449cc by Sebastian Graf at 2023-12-06T08:11:55-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". - - - - - e7732cb8 by Matthew Pickering at 2023-12-06T08:11:56-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 - - - - - 71a6dfc9 by Matthew Pickering at 2023-12-06T08:11:56-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 - - - - - dd0bd6c0 by Zubin Duggal at 2023-12-06T08:11:56-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 - - - - - 154bd2fa by Sylvain Henry at 2023-12-06T08:12:07-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 - - - - - 84477c36 by Sebastian Graf at 2023-12-06T08:12:08-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. - - - - - 30 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Warnings.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - testsuite/tests/ado/T22483.stderr - + testsuite/tests/core-to-stg/T14895.hs - + testsuite/tests/core-to-stg/T14895.stderr - testsuite/tests/core-to-stg/all.T - + testsuite/tests/cpranal/should_compile/T23862.hs - + testsuite/tests/cpranal/should_compile/T23862.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59ecf52b0ce30d680ebb9d411a313001f4d4aadd...84477c363b10ae8e948a02be706286d9f97c273a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59ecf52b0ce30d680ebb9d411a313001f4d4aadd...84477c363b10ae8e948a02be706286d9f97c273a 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 Dec 6 14:30:31 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 06 Dec 2023 09:30:31 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin] testsuite: Skip MultiLayerModulesTH_OneShot on darwin Message-ID: <6570858792f42_2f7fd31c7ae6dc134683@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin at Glasgow Haskell Compiler / GHC Commits: ec0f2835 by Zubin Duggal at 2023-12-06T19:59:40+05:30 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 1 changed file: - testsuite/tests/perf/compiler/all.T Changes: ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -372,7 +372,10 @@ test('MultiLayerModulesTH_OneShot', pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'), extra_files(['genMultiLayerModulesTH']), unless(have_dynamic(),skip), - compile_timeout_multiplier(5) + compile_timeout_multiplier(5), + # We skip the test on darwin due to recent regression due to toolchain + # upgrade (tracked in #24177) + when(opsys('darwin'), skip) ], compile_fail, # see Note [Increased initial stack size for MultiLayerModules] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec0f283544896e9ad41af6be6ef681c3cca3eeac -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ec0f283544896e9ad41af6be6ef681c3cca3eeac 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 Dec 6 15:00:45 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 10:00:45 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] 5 commits: EPA: use IsUnicodeSyntax in EpUniToken Message-ID: <65708c9d6fef5_2f7fd31d55770c1475d1@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: daf66e4d by Vladislav Zavialov at 2023-12-06T13:30:20+03:00 EPA: use IsUnicodeSyntax in EpUniToken - - - - - 30267f0b by Vladislav Zavialov at 2023-12-06T16:29:23+03:00 EPA: move LHsToken into x-field for HsAppType - - - - - de5f2689 by Vladislav Zavialov at 2023-12-06T16:29:23+03:00 EPA: move LHsToken into x-field for HsConPatTyArg - - - - - 5a60a5fb by Vladislav Zavialov at 2023-12-06T17:25:16+03:00 EPA: move LHsToken into x-field for AsPat - - - - - 0f059d51 by Vladislav Zavialov at 2023-12-06T17:40:50+03:00 EPA: use EpToken in HsAppType, HsConPatTyArg, AsPat - - - - - 30 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Expr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41e67a6217d2cb7790509612f821fedc803fcf63...0f059d518c79ece4bac9e565099be5133ab04f0d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/41e67a6217d2cb7790509612f821fedc803fcf63...0f059d518c79ece4bac9e565099be5133ab04f0d 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 Dec 6 16:26:38 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 11:26:38 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T23478 Message-ID: <6570a0be3f1d1_2f7fd31f32a4b4153281@gitlab.mail> Oleg Grenrus pushed new branch wip/T23478 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23478 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 Dec 6 16:57:03 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 11:57:03 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsPar, ParPat, HsCmdPar Message-ID: <6570a7df7816b_2f7fd32019f440176925@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 0d241b7c by Vladislav Zavialov at 2023-12-06T19:56:55+03:00 EPA: use EpToken in HsPar, ParPat, HsCmdPar - - - - - 30 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Pat.hs - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d241b7cb5cc4aa98b2649853268454486ed9a6b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0d241b7cb5cc4aa98b2649853268454486ed9a6b 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 Dec 6 17:06:04 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 12:06:04 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6570a9fbf0ba4_2f7fd3207caacc1775c8@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: efced8b8 by Oleg Grenrus at 2023-12-06T19:05:44+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 5 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -90,6 +94,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +331,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +365,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +409,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +445,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +335,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +371,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/efced8b830f042b2e24d436bc45e9faa6d11756c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/efced8b830f042b2e24d436bc45e9faa6d11756c 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 Dec 6 17:23:13 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Wed, 06 Dec 2023 12:23:13 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24242 Message-ID: <6570ae01162f3_2f7fd320e8ff4c183959@gitlab.mail> Simon Peyton Jones pushed new branch wip/T24242 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24242 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 Dec 6 17:23:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 12:23:34 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Only exit ghci in -e mode when :add command fails Message-ID: <6570ae16c4845_2f7fd320e3bc9418695d@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cf59f7cb by Claudio Bley at 2023-12-06T12:23:05-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 - - - - - d6a8de66 by Vladislav Zavialov at 2023-12-06T12:23:06-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 - - - - - af097a96 by Sebastian Graf at 2023-12-06T12:23:06-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". - - - - - ed15b02e by Matthew Pickering at 2023-12-06T12:23:07-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 - - - - - ac036abe by Matthew Pickering at 2023-12-06T12:23:07-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 - - - - - 9aca6bfa by Zubin Duggal at 2023-12-06T12:23:07-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 - - - - - 971084b0 by Sylvain Henry at 2023-12-06T12:23:20-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 - - - - - 5a009236 by Sebastian Graf at 2023-12-06T12:23:20-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. - - - - - 30 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Warnings.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - testsuite/tests/ado/T22483.stderr - + testsuite/tests/core-to-stg/T14895.hs - + testsuite/tests/core-to-stg/T14895.stderr - testsuite/tests/core-to-stg/all.T - + testsuite/tests/cpranal/should_compile/T23862.hs - + testsuite/tests/cpranal/should_compile/T23862.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84477c363b10ae8e948a02be706286d9f97c273a...5a009236cb9c6a816d516a1c9290ae7009a644c2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84477c363b10ae8e948a02be706286d9f97c273a...5a009236cb9c6a816d516a1c9290ae7009a644c2 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 Dec 6 17:32:01 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 12:32:01 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsEmbTy, EmbTyPat Message-ID: <6570b011ae949_2f7fd320e90fa020047b@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 03b000f7 by Vladislav Zavialov at 2023-12-06T20:31:02+03:00 EPA: use EpToken in HsEmbTy, EmbTyPat - - - - - 21 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Pat.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -374,7 +374,7 @@ type instance XStatic GhcTc = (NameSet, Type) -- Free variables and type of expression, this is stored for convenience as wiring in -- StaticPtr is a bit tricky (see #20150) -type instance XEmbTy GhcPs = NoExtField +type instance XEmbTy GhcPs = EpToken "type" type instance XEmbTy GhcRn = NoExtField type instance XEmbTy GhcTc = DataConCantHappen -- A free-standing HsEmbTy is an error. @@ -720,7 +720,7 @@ ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) ppr_expr (HsStatic _ e) = hsep [text "static", ppr e] -ppr_expr (HsEmbTy _ _ ty) +ppr_expr (HsEmbTy _ ty) = hsep [text "type", ppr ty] ppr_expr (XExpr x) = case ghcPass @p of ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -158,7 +158,7 @@ type instance XSigPat GhcPs = EpAnn [AddEpAnn] type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type -type instance XEmbTyPat GhcPs = NoExtField +type instance XEmbTyPat GhcPs = EpToken "type" type instance XEmbTyPat GhcRn = NoExtField type instance XEmbTyPat GhcTc = Type @@ -390,7 +390,7 @@ pprPat (ConPat { pat_con = con , cpt_dicts = dicts , cpt_binds = binds } = ext -pprPat (EmbTyPat _ toktype tp) = ppr toktype <+> ppr tp +pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp pprPat (XPat ext) = case ghcPass @p of GhcRn -> case ext of ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -63,7 +63,7 @@ hsPatType (ConPat { pat_con = lcon hsPatType (SigPat ty _ _) = ty hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty -hsPatType (EmbTyPat ty _ _) = typeKind ty +hsPatType (EmbTyPat ty _) = typeKind ty hsPatType (XPat ext) = case ext of CoPat _ _ ty -> ty @@ -142,7 +142,7 @@ hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e -hsExprType (HsEmbTy x _ _) = dataConCantHappen x +hsExprType (HsEmbTy x _) = dataConCantHappen x hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -1248,7 +1248,7 @@ collect_pat flag pat bndrs = case pat of CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig XPat ext -> collectXXPat @p flag ext bndrs SplicePat ext _ -> collectXSplicePat @p flag ext bndrs - EmbTyPat _ _ tp -> case flag of + EmbTyPat _ tp -> case flag of CollNoDictBinders -> bndrs CollWithDictBinders -> bndrs CollVarTyVarBinders -> collectTyPatBndrs tp ++ bndrs ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -415,7 +415,7 @@ dsExpr (ExplicitSum types alt arity expr) dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr -dsExpr (HsEmbTy x _ _) = dataConCantHappen x +dsExpr (HsEmbTy x _) = dataConCantHappen x dsExpr (HsCase ctxt discrim matches) = do { core_discrim <- dsLExpr discrim ===================================== compiler/GHC/HsToCore/Pmc/Desugar.hs ===================================== @@ -123,7 +123,7 @@ desugarPat x pat = case pat of AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p SigPat _ p _ty -> desugarLPat x p - EmbTyPat _ _ _ -> pure [] + EmbTyPat _ _ -> pure [] XPat ext -> case ext of ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1664,7 +1664,7 @@ repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do e1 <- repLE e repGetField e1 f repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs) -repE (HsEmbTy _ _ t) = do +repE (HsEmbTy _ t) = do t1 <- repLTy (hswc_body t) rep2 typeEName [unC t1] repE (XExpr (HsExpanded orig_expr ds_expr)) @@ -2124,8 +2124,8 @@ repP p@(NPat _ (L _ l) (Just _) _) repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } -repP (EmbTyPat _ _ t) = do { t' <- repLTy (hstp_body t) - ; repPtype t' } +repP (EmbTyPat _ t) = do { t' <- repLTy (hstp_body t) + ; repPtype t' } repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) repP other = notHandled (ThExoticPattern other) ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1028,7 +1028,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where sig HieRn -> pure [] ] - EmbTyPat _ _ tp -> + EmbTyPat _ tp -> [ toHie $ TS (ResolvedScopes [scope, pscope]) tp ] XPat e -> @@ -1264,7 +1264,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where HsStatic _ expr -> [ toHie expr ] - HsEmbTy _ _ ty -> + HsEmbTy _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] HsTypedBracket xbracket b -> case hiePass @p of ===================================== compiler/GHC/Parser.y ===================================== @@ -2736,7 +2736,7 @@ exp :: { ECP } -- Embed types into expressions and patterns for required type arguments | 'type' atype {% do { requireExplicitNamespaces (getLoc $1) - ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (hsTok $1) $2 } } + ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (epTok $1) $2 } } infixexp :: { ECP } : exp10 { $1 } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1647,7 +1647,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkSumOrTuplePV :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "type t" (embedded type) - mkHsEmbTyPV :: SrcSpan -> LHsToken "type" GhcPs -> LHsType GhcPs -> PV (LocatedA b) + mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b) -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas rejectPragmaPV :: LocatedA b -> PV () @@ -1865,7 +1865,7 @@ instance DisambECP (HsExpr GhcPs) where mkSumOrTuplePV = mkSumOrTupleExpr mkHsEmbTyPV l toktype ty = return $ L (noAnnSrcSpan l) $ - HsEmbTy noExtField toktype (mkHsWildCardBndrs ty) + HsEmbTy toktype (mkHsWildCardBndrs ty) rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e @@ -1954,7 +1954,7 @@ instance DisambECP (PatBuilder GhcPs) where mkSumOrTuplePV = mkSumOrTuplePat mkHsEmbTyPV l toktype ty = return $ L (noAnnSrcSpan l) $ - PatBuilderPat (EmbTyPat noExtField toktype (mkHsTyPat noAnn ty)) + PatBuilderPat (EmbTyPat toktype (mkHsTyPat noAnn ty)) rejectPragmaPV _ = return () -- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#. ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -560,9 +560,9 @@ rnExpr (ArithSeq _ _ seq) else return (ArithSeq noExtField Nothing new_seq, fvs) } -rnExpr (HsEmbTy _ toktype ty) +rnExpr (HsEmbTy _ ty) = do { (ty', fvs) <- rnHsWcType HsTypeCtx ty - ; return (HsEmbTy noExtField toktype ty', fvs) } + ; return (HsEmbTy noExtField ty', fvs) } {- ************************************************************************ ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -635,9 +635,9 @@ rnPatAndThen mk (SplicePat _ splice) (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed } -rnPatAndThen _ (EmbTyPat _ toktype tp) +rnPatAndThen _ (EmbTyPat _ tp) = do { tp' <- rnHsTyPat HsTypePatCtx tp - ; return (EmbTyPat noExtField toktype tp') } + ; return (EmbTyPat noExtField tp') } -------------------- rnConPatAndThen :: NameMaker ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -750,8 +750,8 @@ looks_like_type_arg EValArg{ eva_arg = ValArg (L _ e) } = -- type arguments without the `type` qualifier, so `f True` could -- instantiate `forall (b :: Bool) -> t`. case stripParensHsExpr e of - HsEmbTy _ _ _ -> True - _ -> False + HsEmbTy _ _ -> True + _ -> False looks_like_type_arg _ = False addArgCtxt :: AppCtxt -> LHsExpr GhcRn @@ -817,7 +817,7 @@ tcVDQ conc_tvs (tvb, inner_ty) arg expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn) expr_to_type earg = case stripParensLHsExpr earg of - L _ (HsEmbTy _ _ hs_ty) -> + L _ (HsEmbTy _ hs_ty) -> -- The entire type argument is guarded with the `type` herald, -- e.g. `vfun (type (Maybe Int))`. This special case supports -- named wildcards. See Note [Wildcards in the T2T translation] @@ -829,7 +829,7 @@ expr_to_type earg = HsWC [] <$> go e where go :: LHsExpr GhcRn -> TcM (LHsType GhcRn) - go (L _ (HsEmbTy _ _ t)) = + go (L _ (HsEmbTy _ t)) = -- HsEmbTy means there is an explicit `type` herald, e.g. vfun :: forall a -> blah -- and the call vfun (type Int) -- or vfun (Int -> type Int) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -468,7 +468,7 @@ tcExpr (HsStatic fvs expr) res_ty (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) } -tcExpr (HsEmbTy _ _ _) _ = failWith TcRnIllegalTypeExpr +tcExpr (HsEmbTy _ _) _ = failWith TcRnIllegalTypeExpr {- ************************************************************************ ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -389,13 +389,13 @@ tc_tt_pat (ExpFunPatTy pat_ty) penv pat thing_inside = tc_pat pat_ty penv pat th tc_tt_pat (ExpForAllPatTy tv) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc) -tc_forall_pat _ (EmbTyPat _ toktype tp, tv) thing_inside +tc_forall_pat _ (EmbTyPat _ tp, tv) thing_inside = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat tp (varType tv) ; _ <- unifyType Nothing arg_ty (mkTyVarTy tv) ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside - ; return (EmbTyPat arg_ty toktype tp, result) } + ; return (EmbTyPat arg_ty tp, result) } tc_forall_pat _ (pat, _) _ = failWith $ TcRnIllformedTypePattern pat tc_pat :: Scaled ExpSigmaTypeFRR @@ -737,7 +737,7 @@ AST is used for the subtraction operation. SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" - EmbTyPat _ _ _ -> failWith TcRnIllegalTypePattern + EmbTyPat _ _ -> failWith TcRnIllegalTypePattern XPat (HsPatExpanded lpat rpat) -> do { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -1050,7 +1050,7 @@ tcPatToExpr args pat = go pat | otherwise = return $ HsOverLit noAnn n go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" - go1 (EmbTyPat _ toktype tp) = return $ HsEmbTy noExtField toktype (hstp_to_hswc tp) + go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty }) = HsWC { hswc_ext = wcs, hswc_body = hs_ty } ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1059,7 +1059,7 @@ zonkExpr (HsStatic (fvs, ty) expr) = do new_ty <- zonkTcTypeToTypeX ty HsStatic (fvs, new_ty) <$> zonkLExpr expr -zonkExpr (HsEmbTy x _ _) = dataConCantHappen x +zonkExpr (HsEmbTy x _) = dataConCantHappen x zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr))) = runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> @@ -1570,9 +1570,9 @@ zonk_pat (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) ; n' <- zonkIdBndrX n ; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } -zonk_pat (EmbTyPat ty toktype tp) +zonk_pat (EmbTyPat ty tp) = do { ty' <- noBinders $ zonkTcTypeToTypeX ty - ; return (EmbTyPat ty' toktype tp) } + ; return (EmbTyPat ty' tp) } zonk_pat (XPat ext) = case ext of { ExpansionPat orig pat-> ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1165,7 +1165,7 @@ cvtl e = wrapLA (cvt e) cvt (TypedBracketE e) = do { e' <- cvtl e ; return $ HsTypedBracket noAnn e' } cvt (TypeE t) = do { t' <- cvtType t - ; return $ HsEmbTy noExtField noHsTok (mkHsWildCardBndrs t') } + ; return $ HsEmbTy noAnn (mkHsWildCardBndrs t') } {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: @@ -1483,7 +1483,7 @@ cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat noAnn e' p'} cvtp (TypeP t) = do { t' <- cvtType t - ; return $ EmbTyPat noExtField noHsTok (mkHsTyPat noAnn t') } + ; return $ EmbTyPat noAnn (mkHsTyPat noAnn t') } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -25,7 +25,6 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds @@ -578,7 +577,6 @@ data HsExpr p -- Embed the syntax of types into expressions. -- Used with RequiredTypeArguments, e.g. fn (type (Int -> Bool)) | HsEmbTy (XEmbTy p) - !(LHsToken "type" p) (LHsWcType (NoGhcTc p)) | XExpr !(XXExpr p) ===================================== compiler/Language/Haskell/Syntax/Pat.hs ===================================== @@ -36,7 +36,6 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntyp -- friends: import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type @@ -219,7 +218,6 @@ data Pat p -- Embed the syntax of types into patterns. -- Used with RequiredTypeArguments, e.g. fn (type t) = rhs | EmbTyPat (XEmbTyPat p) - !(LHsToken "type" p) (HsTyPat (NoGhcTc p)) -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3210,6 +3210,12 @@ instance ExactPrint (HsExpr GhcPs) where prag' <- markAnnotated prag e' <- markAnnotated e return (HsPragE a prag' e') + + exact (HsEmbTy toktype t) = do + toktype' <- markEpToken toktype + t' <- markAnnotated t + return (HsEmbTy toktype' t') + exact x = error $ "exact HsExpr for:" ++ showAst x -- --------------------------------------------------------------------- @@ -4773,7 +4779,7 @@ instance ExactPrint (Pat GhcPs) where getAnnotationEntry (NPat an _ _ _) = fromAnn an getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an getAnnotationEntry (SigPat an _ _) = fromAnn an - getAnnotationEntry (EmbTyPat _ _ _) = NoEntryVal + getAnnotationEntry (EmbTyPat _ _) = NoEntryVal setAnnotationAnchor a@(WildPat _) _ _ _s = a setAnnotationAnchor a@(VarPat _ _) _ _ _s = a @@ -4791,7 +4797,7 @@ instance ExactPrint (Pat GhcPs) where setAnnotationAnchor (NPat an a b c) anc ts cs = (NPat (setAnchorEpa an anc ts cs) a b c) setAnnotationAnchor (NPlusKPat an a b c d e) anc ts cs = (NPlusKPat (setAnchorEpa an anc ts cs) a b c d e) setAnnotationAnchor (SigPat an a b) anc ts cs = (SigPat (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(EmbTyPat _ _ _) _ _ _s = a + setAnnotationAnchor a@(EmbTyPat _ _) _ _ _s = a exact (WildPat w) = do anchor' <- getAnchorU @@ -4879,10 +4885,10 @@ instance ExactPrint (Pat GhcPs) where sig' <- markAnnotated sig return (SigPat an0 pat' sig') - exact (EmbTyPat x toktype tp) = do - toktype' <- markToken toktype + exact (EmbTyPat toktype tp) = do + toktype' <- markEpToken toktype tp' <- markAnnotated tp - return (EmbTyPat x toktype' tp') + return (EmbTyPat toktype' tp') -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03b000f7b0003da7acdee4f741e278bedfdbe7a4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03b000f7b0003da7acdee4f741e278bedfdbe7a4 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 Dec 6 17:39:38 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 12:39:38 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6570b1da56d57_2f7fd3217a3df42056bf@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: f0d4e2c7 by Oleg Grenrus at 2023-12-06T19:39:30+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 5 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +73,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +94,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +331,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +365,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +409,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +445,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +335,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +371,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0d4e2c799840220559974e63b9f884e4bba9aa4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0d4e2c799840220559974e63b9f884e4bba9aa4 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 Dec 6 18:48:12 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 13:48:12 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in LayoutInfo (renamed to EpLayout) Message-ID: <6570c1ecd9fe2_2f7fd3230603602079f4@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: cf6a1b7e by Vladislav Zavialov at 2023-12-06T21:47:58+03:00 EPA: use EpToken in LayoutInfo (renamed to EpLayout) - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Concrete.hs - compiler/Language/Haskell/Syntax/Decls.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/T18791.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf6a1b7e98c7df8bf2057f51923992567e24c309 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cf6a1b7e98c7df8bf2057f51923992567e24c309 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 Dec 6 19:08:00 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Wed, 06 Dec 2023 14:08:00 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Sign-extend branche conditionals W32 -> W64 Message-ID: <6570c69067fb8_2f7fd3237cf920213073@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: f8065a34 by Sven Tennie at 2023-12-06T20:06:10+01:00 Sign-extend branche conditionals W32 -> W64 Otherwise, negative ints are used as positive ints. - - - - - 1 changed file: - compiler/GHC/CmmToAsm/RV64/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/CodeGen.hs ===================================== @@ -1266,6 +1266,7 @@ genCondJump bid expr = do (reg_y, format_y, code_y) <- getSomeReg y let x' = OpReg w reg_x y' = OpReg w reg_y + -- TODO: Reduce duplication in this block. return $ case w of W8 -> code_x @@ -1279,6 +1280,12 @@ genCondJump bid expr = do `appOL` code_y `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid))) + W32 -> + code_x + `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x + `appOL` code_y + `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y + `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid))) _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid))) fbcond w cmp = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8065a34de2e9d01e3bf7507b0e4860ebcd9bc21 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8065a34de2e9d01e3bf7507b0e4860ebcd9bc21 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 Dec 6 20:10:03 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 15:10:03 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6570d51b279d3_2f7fd325443cc821806a@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: fc180a4a by Oleg Grenrus at 2023-12-06T22:09:54+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 5 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +73,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +94,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +331,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +365,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +409,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +445,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +335,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +371,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc180a4a897de7c4d395d50be41c30cb43ae403b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc180a4a897de7c4d395d50be41c30cb43ae403b 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 Dec 6 20:12:33 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 15:12:33 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6570d5b13bc1e_2f7fd3255a8dac21852f@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: 3240dcbd by Oleg Grenrus at 2023-12-06T22:12:22+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 5 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +73,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +94,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +-- PackageImports can be removed once base's GHC.TypeLits.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +334,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +368,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +412,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +448,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +-- PackageImports can be removed once base's GHC.TypeNats.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +338,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +374,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3240dcbd27f77f19465be44e8cf56d8eb0f27572 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3240dcbd27f77f19465be44e8cf56d8eb0f27572 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 Dec 6 20:49:43 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Wed, 06 Dec 2023 15:49:43 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Fix float NE: Needed width Message-ID: <6570de671f1e1_2f7fd32622d0c82225a1@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 467ae53a by Sven Tennie at 2023-12-06T21:49:14+01:00 Fix float NE: Needed width - - - - - 1 changed file: - compiler/GHC/CmmToAsm/RV64/Ppr.hs Changes: ===================================== compiler/GHC/CmmToAsm/RV64/Ppr.hs ===================================== @@ -584,7 +584,8 @@ pprInstr platform instr = case instr of , text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o] -- feq.s a0,fa0,fa1 -- xori a0,a0,1 - NE | isFloatOp l && isFloatOp r -> lines_ [binOp "\tfeq.s", text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"] + NE | isFloatOp l && isFloatOp r -> lines_ [binOp ("\tfeq." ++ floatOpPrecision platform l r) + , text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"] SLT -> lines_ [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r ] SLE -> lines_ [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l , text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1" ] @@ -717,8 +718,8 @@ pprInstr platform instr = case instr of pprDmbType DmbReadWrite = text "rw" floatOpPrecision :: Platform -> Operand -> Operand -> String -floatOpPrecision p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision -floatOpPrecision p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision +floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision +floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r) pprBcond :: IsLine doc => Cond -> doc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/467ae53a3a4681f87ea51fcbf06339ddde745a15 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/467ae53a3a4681f87ea51fcbf06339ddde745a15 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 Dec 6 21:14:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:14:13 -0500 Subject: [Git][ghc/ghc][master] Only exit ghci in -e mode when :add command fails Message-ID: <6570e425a8395_2f7fd326c01acc22982f@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 4 changed files: - ghc/GHCi/UI.hs - + testsuite/tests/ghci/should_run/T24115.hs - + testsuite/tests/ghci/should_run/T24115.script - testsuite/tests/ghci/should_run/all.T Changes: ===================================== ghc/GHCi/UI.hs ===================================== @@ -2098,8 +2098,9 @@ addModule files = do checkTargetFile :: GhciMonad m => String -> m Bool checkTargetFile f = do exists <- liftIO (doesFileExist f) - unless exists $ liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found" - failIfExprEvalMode + unless exists $ do + liftIO $ hPutStrLn stderr $ "File " ++ f ++ " not found" + failIfExprEvalMode return exists -- | @:unadd@ command ===================================== testsuite/tests/ghci/should_run/T24115.hs ===================================== @@ -0,0 +1,2 @@ + +loaded = True ===================================== testsuite/tests/ghci/should_run/T24115.script ===================================== @@ -0,0 +1 @@ +loaded ===================================== testsuite/tests/ghci/should_run/all.T ===================================== @@ -92,3 +92,6 @@ test('T22958b', just_ghci, compile_and_run, ['']) test('T22958c', just_ghci, compile_and_run, ['']) test('GhciMainIs', just_ghci, compile_and_run, ['-main-is otherMain']) test('LargeBCO', [extra_files(['LargeBCO_A.hs']), req_interp, extra_hc_opts("-O -fbyte-code-and-object-code -fprefer-byte-code")], compile_and_run, ['']) + +test('T24115', just_ghci + [extra_run_opts("-e ':add T24115.hs'")], ghci_script, ['T24115.script']) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d561073727186c7b456c9ef113ccb7fc0df4560e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d561073727186c7b456c9ef113ccb7fc0df4560e 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 Dec 6 21:14:50 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:14:50 -0500 Subject: [Git][ghc/ghc][master] T2T in Patterns (#23739) Message-ID: <6570e44acfec9_2f7fd326c993f423334c@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 30 changed files: - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - testsuite/tests/module/mod132.stderr - testsuite/tests/module/mod147.stderr - testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr - testsuite/tests/rename/should_fail/T18740a.stderr - testsuite/tests/rename/should_fail/T18740b.stderr - testsuite/tests/th/T14627.stderr - testsuite/tests/th/T18740c.stderr - testsuite/tests/type-data/should_fail/TDExpression.stderr - testsuite/tests/typecheck/should_fail/T19978.stderr - + testsuite/tests/vdq-rta/should_compile/T23739_idv.hs - + testsuite/tests/vdq-rta/should_compile/T23739_nested.hs - + testsuite/tests/vdq-rta/should_compile/T23739_sig.hs - + testsuite/tests/vdq-rta/should_compile/T23739_sizeOf.hs - + testsuite/tests/vdq-rta/should_compile/T23739_symbolVal.hs - + testsuite/tests/vdq-rta/should_compile/T23739_th_dump1.hs - + testsuite/tests/vdq-rta/should_compile/T23739_th_dump1.stderr - + testsuite/tests/vdq-rta/should_compile/T23739_th_pprint1.hs - + testsuite/tests/vdq-rta/should_compile/T23739_th_pprint1.stderr - + testsuite/tests/vdq-rta/should_compile/T23739_typeRep.hs - testsuite/tests/vdq-rta/should_compile/all.T - testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs - testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f0c53a501ba7740cc896bdb3a2b153512183955 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f0c53a501ba7740cc896bdb3a2b153512183955 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 Dec 6 21:16:05 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:16:05 -0500 Subject: [Git][ghc/ghc][master] Pmc: Fix SrcLoc and warning for incomplete irrefutable pats (#24234) Message-ID: <6570e495c93f5_2f7fd326c993f42398df@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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". - - - - - 12 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Utils.hs - compiler/Language/Haskell/Syntax/Expr.hs - testsuite/tests/ado/T22483.stderr - testsuite/tests/deSugar/should_run/dsrun008.stderr - + testsuite/tests/pmcheck/should_compile/T24234.hs - + testsuite/tests/pmcheck/should_compile/T24234.stderr - testsuite/tests/pmcheck/should_compile/all.T Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1469,6 +1469,21 @@ pprGRHS ctxt (GRHS _ guards body) pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator LamAlt{} = text "->" +matchSeparator IfAlt = text "->" +matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern +matchSeparator PatSyn = text "<-" -- match checker trace +matchSeparator LazyPatCtx = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" + instance Outputable GrhsAnn where ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s @@ -1931,6 +1946,7 @@ instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where ppr ThPatSplice = text "ThPatSplice" ppr ThPatQuote = text "ThPatQuote" ppr PatSyn = text "PatSyn" + ppr LazyPatCtx = text "LazyPatCtx" instance Outputable HsLamVariant where ppr = text . \case @@ -1981,6 +1997,7 @@ matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (Stm matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour +matchContextErrString LazyPatCtx = text "irrefutable pattern" matchArrowContextErrString :: HsArrowMatchContext -> SDoc matchArrowContextErrString ProcExpr = text "proc" @@ -2022,20 +2039,6 @@ pprStmtInCtxt ctxt stmt , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt -matchSeparator :: HsMatchContext p -> SDoc -matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator StmtCtxt{} = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern -matchSeparator PatSyn = text "<-" -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" - pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc pprMatchContext ctxt @@ -2045,6 +2048,7 @@ pprMatchContext ctxt want_an (FunRhs {}) = True -- Use "an" in front want_an (ArrowMatchCtxt ProcExpr) = True want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True + want_an LazyPatCtx = True want_an _ = False pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) @@ -2065,6 +2069,7 @@ pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn = text "pattern synonym declaration" +pprMatchContextNoun LazyPatCtx = text "irrefutable pattern" pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -237,7 +237,7 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss ; body_expr <- dsGuarded grhss ty rhss_nablas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body' -- We silently ignore inline pragmas; no makeCorePair -- Not so cool, but really doesn't matter ; let force_var' = if isBangedLPat pat' ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -451,13 +451,13 @@ tidy1 v _ (LazyPat _ pat) -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) + = putSrcSpanDs (getLocA pat) $ + do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLocA pat) $ diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } ===================================== compiler/GHC/HsToCore/Pmc.hs ===================================== @@ -118,6 +118,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p then id else discardWarningsDs want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True want_pmc (StmtCtxt stmt_ctxt) = case stmt_ctxt of PatGuard {} -> False ===================================== compiler/GHC/HsToCore/Pmc/Utils.hs ===================================== @@ -91,6 +91,7 @@ exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd +exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing exhaustiveWarningFlag ThPatQuote = Nothing ===================================== compiler/GHC/HsToCore/Utils.hs ===================================== @@ -597,7 +597,12 @@ mkSelectorBinds is used to desugar a pattern binding {p = e}, in a binding group: let { ...; p = e; ... } in body where p binds x,y (this list of binders can be empty). -There are two cases. + +mkSelectorBinds is also used to desugar irrefutable patterns, which is the +pattern syntax equivalent of a lazy pattern binding: + f (~(a:as)) = rhs ==> f x = let (a:as) = x in rhs + +There are three cases. ------ Special case (A) ------- For a pattern that is just a variable, @@ -634,7 +639,7 @@ There are two cases. Note that (C) /includes/ the situation where * The pattern binds exactly one variable - let !(Just (Just x) = e in body + let !(Just (Just x)) = e in body ==> let { t = case e of Just (Just v) -> Solo v ; v = case t of Solo v -> v } @@ -726,15 +731,16 @@ work out well: -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced. -mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound +mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> HsMatchContext GhcTc -- ^ Where the pattern occurs + -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") -- and all the desugared binds -mkSelectorBinds ticks pat val_expr +mkSelectorBinds ticks pat ctx val_expr | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) @@ -745,7 +751,7 @@ mkSelectorBinds ticks pat val_expr ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + = do { rhs_expr <- matchSimply (Var val_var) ctx pat' (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the @@ -760,7 +766,7 @@ mkSelectorBinds ticks pat val_expr | otherwise -- General case (C) = do { tuple_var <- newSysLocalDs ManyTy tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') - ; tuple_expr <- matchSimply val_expr PatBindRhs pat + ; tuple_expr <- matchSimply val_expr ctx pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ ===================================== compiler/Language/Haskell/Syntax/Expr.hs ===================================== @@ -1576,6 +1576,7 @@ data HsMatchContext p | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration + | LazyPatCtx -- ^An irrefutable pattern {- Note [mc_fun field of FunRhs] ===================================== testsuite/tests/ado/T22483.stderr ===================================== @@ -2,7 +2,7 @@ T22483.hs:1:1: warning: [GHC-38417] [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: main :: IO () -T22483.hs:4:3: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] +T22483.hs:4:4: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] Pattern match(es) are non-exhaustive - In a pattern binding: + In an irrefutable pattern: Patterns of type ‘Maybe ()’ not matched: Nothing ===================================== testsuite/tests/deSugar/should_run/dsrun008.stderr ===================================== @@ -1,2 +1,2 @@ -dsrun008: dsrun008.hs:2:15-42: Non-exhaustive patterns in (2, x) +dsrun008: dsrun008.hs:2:32-36: Non-exhaustive patterns in (2, x) ===================================== testsuite/tests/pmcheck/should_compile/T24234.hs ===================================== @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -W #-} + +module T24234 where + +foo :: [()] -> () +foo ~(a:_) = a +foo _ = () ===================================== testsuite/tests/pmcheck/should_compile/T24234.stderr ===================================== @@ -0,0 +1,8 @@ + +T24234.hs:6:6: warning: [GHC-62161] [-Wincomplete-uni-patterns (in -Wall)] + Pattern match(es) are non-exhaustive + In an irrefutable pattern: Patterns of type ‘[()]’ not matched: [] + +T24234.hs:7:1: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In an equation for ‘foo’: foo _ = ... ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -120,6 +120,7 @@ test('T19271', [], compile, [overlapping_incomplete]) test('T21761', [], compile, [overlapping_incomplete]) test('T22964', [], compile, [overlapping_incomplete]) test('T23445', [], compile, [overlapping_incomplete]) +test('T24234', [], compile, [overlapping_incomplete+'-Wincomplete-uni-patterns']) # Series (inspired) by Luke Maranget @@ -166,4 +167,4 @@ test('EmptyCase009', [], compile, [overlapping_incomplete]) test('EmptyCase010', [], compile, [overlapping_incomplete]) test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors']) test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors']) -test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) \ No newline at end of file +test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10a1a6c635dcd8b3db5ef8bb7195717a75ebb935 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10a1a6c635dcd8b3db5ef8bb7195717a75ebb935 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 Dec 6 21:17:25 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 16:17:25 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsAppKindTy, HsArg, HsBndrVis Message-ID: <6570e4e5d8c9e_2f7fd326c01acc24297b@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 1ac43f97 by Vladislav Zavialov at 2023-12-07T00:15:04+03:00 EPA: use EpToken in HsAppKindTy, HsArg, HsBndrVis - - - - - 25 changed files: - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Type.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - utils/check-exact/ExactPrint.hs - utils/haddock Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -101,7 +101,6 @@ import Language.Haskell.Syntax.Type import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension @@ -340,6 +339,14 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where getName (UserTyVar _ _ v) = unLoc v getName (KindedTyVar _ _ v _) = unLoc v +type instance XBndrRequired (GhcPass _) = NoExtField + +type instance XBndrInvisible GhcPs = EpToken "@" +type instance XBndrInvisible GhcRn = NoExtField +type instance XBndrInvisible GhcTc = NoExtField + +type instance XXBndrVis (GhcPass _) = DataConCantHappen + type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] @@ -354,7 +361,9 @@ type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] -type instance XAppKindTy (GhcPass _) = NoExtField +type instance XAppKindTy GhcPs = EpToken "@" +type instance XAppKindTy GhcRn = NoExtField +type instance XAppKindTy GhcTc = NoExtField type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) @@ -546,10 +555,10 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p) +mkHsAppKindTy :: XAppKindTy (GhcPass p) + -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppKindTy ty at k - = addCLocA ty k (HsAppKindTy noExtField ty at k) +mkHsAppKindTy x ty k = addCLocA ty k (HsAppKindTy x ty k) {- ************************************************************************ @@ -598,7 +607,7 @@ hsTyGetAppHead_maybe = go where go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l - go (L _ (HsAppKindTy _ t _ _)) = go t + go (L _ (HsAppKindTy _ t _)) = go t go (L _ (HsOpTy _ _ _ ln _)) = Just ln go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t @@ -606,19 +615,29 @@ hsTyGetAppHead_maybe = go ------------------------------------------------------------ +type instance XValArg (GhcPass _) = NoExtField + +type instance XTypeArg GhcPs = EpToken "@" +type instance XTypeArg GhcRn = NoExtField +type instance XTypeArg GhcTc = NoExtField + +type instance XArgPar (GhcPass _) = SrcSpan + +type instance XXArg (GhcPass _) = DataConCantHappen + -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'. -lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan +lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan lhsTypeArgSrcSpan arg = case arg of - HsValArg tm -> getLocA tm - HsTypeArg at ty -> getTokenSrcSpan (getLoc at) `combineSrcSpans` getLocA ty + HsValArg _ tm -> getLocA tm + HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty HsArgPar sp -> sp -------------------------------- numVisibleArgs :: [HsArg p tm ty] -> Arity numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False + where is_vis (HsValArg _ _) = True + is_vis _ = False -------------------------------- @@ -633,7 +652,7 @@ numVisibleArgs = count is_vis -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc + => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args) | Infix <- fixity = let pp_op_app = hsep [ ppr_single_hs_arg argl @@ -648,7 +667,7 @@ pprHsArgsApp thing _fixity args -- | Pretty-print a prefix identifier to a list of 'HsArg's. ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) - => SDoc -> [HsArg p tm ty] -> SDoc + => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc ppr_hs_args_prefix_app acc [] = acc ppr_hs_args_prefix_app acc (arg:args) = case arg of @@ -658,8 +677,8 @@ ppr_hs_args_prefix_app acc (arg:args) = -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg p tm ty -> SDoc -ppr_single_hs_arg (HsValArg tm) = ppr tm + => HsArg (GhcPass p) tm ty -> SDoc +ppr_single_hs_arg (HsValArg _ tm) = ppr tm ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty -- GHC shouldn't be constructing ASTs such that this case is ever reached. -- Still, it's possible some wily user might construct their own AST that @@ -669,8 +688,8 @@ ppr_single_hs_arg (HsArgPar{}) = empty -- | This instance is meant for debug-printing purposes. If you wish to -- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty + ppr (HsValArg _ tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg _ ty) = text "HsTypeArg" <+> ppr ty ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -------------------------------- @@ -1041,13 +1060,13 @@ instance OutputableBndrFlag Specificity p where pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k] pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k] -instance OutputableBndrFlag (HsBndrVis p') p where +instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where pprTyVarBndr (UserTyVar _ vis n) = pprHsBndrVis vis $ ppr n pprTyVarBndr (KindedTyVar _ vis n k) = pprHsBndrVis vis $ parens $ hsep [ppr n, dcolon, ppr k] -pprHsBndrVis :: HsBndrVis pass -> SDoc -> SDoc -pprHsBndrVis HsBndrRequired d = d +pprHsBndrVis :: HsBndrVis (GhcPass p) -> SDoc -> SDoc +pprHsBndrVis (HsBndrRequired _) d = d pprHsBndrVis (HsBndrInvisible _) d = char '@' <> d instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where @@ -1273,7 +1292,7 @@ ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsAppKindTy _ ty _ k) +ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 @@ -1388,7 +1407,7 @@ lhsTypeHasLeadingPromotionQuote ty go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy _ t _) = goL t - go (HsAppKindTy _ t _ _) = goL t + go (HsAppKindTy _ t _) = goL t go (HsParTy{}) = False go (HsDocTy _ t _) = goL t go (XHsType{}) = False ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -633,28 +633,32 @@ nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x)) nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) a b) nlHsParTy t = noLocA (HsParTy noAnn t) -nlHsTyConApp :: IsSrcSpanAnn p a +nlHsTyConApp :: forall p a. IsSrcSpanAnn p a => PromotionFlag -> LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp prom fixity tycon tys | Infix <- fixity - , HsValArg ty1 : HsValArg ty2 : rest <- tys + , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest | otherwise = foldl' mk_app (nlHsTyVar prom tycon) tys where mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) - mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg -- parenthesize things like `(A + B) C` - mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun ty) - mk_app fun (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at ki) - mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun) + mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty + mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki + mk_app fun (HsArgPar _) = nlHsParTy fun -nlHsAppKindTy :: +nlHsAppKindTy :: forall p. IsPass p => LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) -nlHsAppKindTy f k - = noLocA (HsAppKindTy noExtField f noHsTok k) +nlHsAppKindTy f k = noLocA (HsAppKindTy x f k) + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField {- Tuples. All these functions are *pre-typechecker* because they lack ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -693,21 +693,21 @@ repTyFamEqn (FamEqn { feqn_tycon = tc_name ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } ; rhs1 <- repLTy rhs ; repTySynEqn mb_exp_bndrs tys1 rhs1 } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _:HsValArg _:_) = return tys + checkTys tys@(HsValArg _ _:HsValArg _ _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys" repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) repTyArgs f [] = f -repTyArgs f (HsValArg ty : as) = do { f' <- f - ; ty' <- repLTy ty - ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsValArg _ ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f ; ki' <- repLTy ki ; repTyArgs (repTappKind f' ki') as } @@ -724,14 +724,14 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _: HsValArg _: _) = return tys + checkTys tys@(HsValArg _ _: HsValArg _ _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -1187,7 +1187,7 @@ instance RepTV (HsBndrVis GhcRn) TH.BndrVis where ; rep2 kindedBndrTVName [nm, vis', ki] } rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis) -rep_bndr_vis HsBndrRequired = rep2_nw bndrReqName [] +rep_bndr_vis (HsBndrRequired _) = rep2_nw bndrReqName [] rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName [] addHsOuterFamEqnTyVarBinds :: @@ -1400,7 +1400,7 @@ repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsAppKindTy _ ty _ ki) = do +repTy (HsAppKindTy _ ty ki) = do ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -555,8 +555,8 @@ instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where HsOuterExplicit{hso_bndrs = tvs} -> foldl1' combineSrcSpans [getHasLoc a, getHasLocList tvs, getHasLocList b, getHasLoc c] -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg p tm ty) where - getHasLoc (HsValArg tm) = getHasLoc tm +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg (GhcPass p) tm ty) where + getHasLoc (HsValArg _ tm) = getHasLoc tm getHasLoc (HsTypeArg _ ty) = getHasLoc ty getHasLoc (HsArgPar sp) = sp @@ -1839,7 +1839,7 @@ instance ToHie (LocatedA (HsType GhcRn)) where [ toHie a , toHie b ] - HsAppKindTy _ ty _ ki -> + HsAppKindTy _ ty ki -> [ toHie ty , toHie ki ] @@ -1897,8 +1897,8 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsStarTy _ _ -> [] XHsType _ -> [] -instance (ToHie tm, ToHie ty) => ToHie (HsArg p tm ty) where - toHie (HsValArg tm) = toHie tm +instance (ToHie tm, ToHie ty) => ToHie (HsArg (GhcPass p) tm ty) where + toHie (HsValArg _ tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = locOnly sp ===================================== compiler/GHC/Parser.y ===================================== @@ -2242,7 +2242,7 @@ ftype :: { forall b. DisambTD b => PV (LocatedA b) } | ftype tyarg { $1 >>= \ $1 -> mkHsAppTyPV $1 $2 } | ftype PREFIX_AT atype { $1 >>= \ $1 -> - mkHsAppKindTyPV $1 (hsTok $2) $3 } + mkHsAppKindTyPV $1 (epTok $2) $3 } tyarg :: { LHsType GhcPs } : atype { $1 } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -9,7 +9,9 @@ module GHC.Parser.Annotation ( -- * Core Exact Print Annotation types AnnKeywordId(..), - EpToken(..), EpUniToken(..), EpLayout(..), + EpToken(..), EpUniToken(..), + getEpTokenSrcSpan, + EpLayout(..), EpaComment(..), EpaCommentTok(..), IsUnicodeSyntax(..), unicodeAnn, @@ -382,6 +384,11 @@ deriving instance Eq (EpToken tok) deriving instance KnownSymbol tok => Data (EpToken tok) deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok) +getEpTokenSrcSpan :: EpToken tok -> SrcSpan +getEpTokenSrcSpan NoEpTok = noSrcSpan +getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan +getEpTokenSrcSpan (EpTok (EpaSpan span)) = span + -- | Layout information for declarations. data EpLayout = ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -946,7 +946,7 @@ checkTyVars pp_what equals_or_where tc tparms ; return (mkHsQTvs tvs) } where check (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki - check (HsValArg ty) = chkParens [] [] emptyComments HsBndrRequired ty + check (HsValArg _ ty) = chkParens [] [] emptyComments (HsBndrRequired noExtField) ty check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens @@ -983,11 +983,11 @@ checkTyVars pp_what equals_or_where tc tparms -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used. for_widening :: HsBndrVis GhcPs -> AddEpAnn - for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc - for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) + for_widening (HsBndrInvisible (EpTok loc)) = AddEpAnn AnnAnyclass loc + for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn] - for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan (RealSrcSpan r _mb))) _)) + for_widening_ann (HsBndrInvisible (EpTok (EpaSpan (RealSrcSpan r _mb)))) = EpAnn (realSpanAsAnchor r) [] emptyComments for_widening_ann _ = noAnn @@ -1081,15 +1081,17 @@ checkTyClHdr is_cls ty go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps) go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix - | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps) + | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps) + where lhs = HsValArg noExtField t1 + rhs = HsValArg noExtField t2 go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix where (o,c) = mkParensEpAnn (realSrcSpan l) - go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix - go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix + go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix + go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix = return (L (noAnnSrcSpan l) (nameRdrName tup_name) - , map HsValArg ts, fix, (reverse ops)++cps) + , map (HsValArg noExtField) ts, fix, (reverse ops)++cps) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -2014,7 +2016,7 @@ class DisambTD b where -- | Disambiguate @f x@ (function application or prefix data constructor). mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \@t@ (visible kind application) - mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) + mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) @@ -2023,7 +2025,7 @@ class DisambTD b where instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) - mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki) + mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2) mkUnpackednessPV = addUnpackednessP @@ -2060,7 +2062,7 @@ instance DisambTD DataConBuilder where panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs at ki = - addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $ + addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $ (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) mkHsOpTyPV prom lhs tc rhs = do ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -467,12 +467,12 @@ rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -- renaming a type only, not a kind rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars) -rnLHsTypeArg ctxt (HsValArg ty) +rnLHsTypeArg ctxt (HsValArg _ ty) = do { (tys_rn, fvs) <- rnLHsType ctxt ty - ; return (HsValArg tys_rn, fvs) } -rnLHsTypeArg ctxt (HsTypeArg l ki) + ; return (HsValArg noExtField tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg _ ki) = do { (kis_rn, fvs) <- rnLHsKind ctxt ki - ; return (HsTypeArg l kis_rn, fvs) } + ; return (HsTypeArg noExtField kis_rn, fvs) } rnLHsTypeArg _ (HsArgPar sp) = return (HsArgPar sp, emptyFVs) @@ -638,12 +638,12 @@ rnHsTyKi env (HsAppTy _ ty1 ty2) ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsAppKindTy _ ty at k) +rnHsTyKi env (HsAppKindTy _ ty k) = do { kind_app <- xoptM LangExt.TypeApplications ; unless kind_app (addErr (typeAppErr KindLevel k)) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy noExtField ty' at k', fvs1 `plusFV` fvs2) } + ; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) } rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t @@ -1201,12 +1201,10 @@ rnLHsTyVarBndrVisFlag (L loc bndr) = do addErr (TcRnIllegalInvisTyVarBndr lbndr) return lbndr --- rnHsBndrVis is a no-op. We could use 'coerce' in an ideal world, --- but GHC can't crack this nut because type families are involved: --- HsBndrInvisible stores (LHsToken "@" pass), which is defined via XRec. +-- rnHsBndrVis is almost a no-op, it simply discards the token for "@". rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn -rnHsBndrVis HsBndrRequired = HsBndrRequired -rnHsBndrVis (HsBndrInvisible at) = HsBndrInvisible at +rnHsBndrVis (HsBndrRequired _) = HsBndrRequired noExtField +rnHsBndrVis (HsBndrInvisible _at) = HsBndrInvisible noExtField newTyVarNameRn, newTyVarNameRnImplicit :: Maybe a -- associated class @@ -1956,7 +1954,7 @@ To account for that, we introduce another helper, `filterInScopeNonClassM`, which acts much like `filterInScopeM` but leaves class variables intact. -} extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_tyarg (HsValArg ty) acc = extract_lty ty acc +extract_tyarg (HsValArg _ ty) acc = extract_lty ty acc extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc extract_tyarg (HsArgPar _) acc = acc @@ -2055,7 +2053,7 @@ extract_lty (L _ ty) acc flds HsAppTy _ ty1 ty2 -> extract_lty ty1 $ extract_lty ty2 acc - HsAppKindTy _ ty _ k -> extract_lty ty $ + HsAppKindTy _ ty k -> extract_lty ty $ extract_lty k acc HsListTy _ ty -> extract_lty ty acc HsTupleTy _ _ tys -> extract_ltys tys acc ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -1297,12 +1297,12 @@ rn_ty_pat (HsAppTy _ fun_ty arg_ty) = do arg_ty' <- rn_lty_pat arg_ty pure (HsAppTy noExtField fun_ty' arg_ty') -rn_ty_pat (HsAppKindTy _ ty at ki) = do +rn_ty_pat (HsAppKindTy _ ty ki) = do kind_app <- liftRn $ xoptM LangExt.TypeApplications unless kind_app (liftRn $ addErr (typeAppErr KindLevel ki)) ty' <- rn_lty_pat ty ki' <- rn_lty_pat ki - pure (HsAppKindTy noExtField ty' at ki') + pure (HsAppKindTy noExtField ty' ki') rn_ty_pat (HsFunTy an mult lhs rhs) = do lhs' <- rn_lty_pat lhs ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -846,7 +846,7 @@ expr_to_type earg = go (L l (HsAppType _ lhs rhs)) = do { lhs' <- go lhs ; rhs' <- unwrap_wc rhs - ; return (L l (HsAppKindTy noExtField lhs' noHsTok rhs')) } + ; return (L l (HsAppKindTy noExtField lhs' rhs')) } go (L l e@(OpApp _ lhs op rhs)) = do { lhs' <- go lhs ; op' <- go op ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1551,12 +1551,12 @@ splitHsAppTys hs_ty -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)] -> (LHsType GhcRn, [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as) + go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as) + go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) go (L _ (HsOpTy _ prom l op@(L sp _) r)) as = ( L (l2l sp) (HsTyVar noAnn prom op) - , HsValArg l : HsValArg r : as ) + , HsValArg noExtField l : HsValArg noExtField r : as ) go f as = (f, as) --------------------------- @@ -1672,7 +1672,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args ty_app_err ki_arg substed_fun_ki ---------------- HsValArg: a normal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) + (HsValArg _ arg : args, Just (ki_binder, inner_ki)) -- next binder is invisible; need to instantiate it | Named (Bndr kv flag) <- ki_binder , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified @@ -1693,7 +1693,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args ; go (n+1) fun' subst' inner_ki args } -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) + (HsValArg _ _ : _, Nothing) -> try_again_after_substing_or $ do { let arrows_needed = n_initial_val_args all_args ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki @@ -1920,10 +1920,10 @@ unsaturated arguments: see #11246. Hence doing this in tcInferApps. appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsValArg _ arg : args) = appTypeToArg (mkHsAppTy f arg) args appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg at arg : args) - = appTypeToArg (mkHsAppKindTy f at arg) args +appTypeToArg f (HsTypeArg _ arg : args) + = appTypeToArg (mkHsAppKindTy noExtField f arg) args {- ********************************************************************* @@ -2470,7 +2470,7 @@ mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently -> TyConBinder mkExplicitTyConBinder dep_set (Bndr tv flag) = case flag of - HsBndrRequired -> mkRequiredTyConBinder dep_set tv + HsBndrRequired{} -> mkRequiredTyConBinder dep_set tv HsBndrInvisible{} -> mkNamedTyConBinder Specified tv -- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and @@ -2741,7 +2741,7 @@ matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside -- See GHC Proposal #425, section "Kind checking", -- where zippable and skippable are defined. zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool - zippable vis HsBndrRequired = isVisibleTcbVis vis + zippable vis (HsBndrRequired _) = isVisibleTcbVis vis zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- See GHC Proposal #425, section "Kind checking", ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -298,7 +298,7 @@ no_anon_wc_ty lty = go lty go (L _ ty) = case ty of HsWildCardTy _ -> False HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty _ ki -> go ty && go ki + HsAppKindTy _ ty ki -> go ty && go ki HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -562,7 +562,7 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) , feqn_tycon = nm' , feqn_bndrs = outer_bndrs , feqn_pats = - (map HsValArg args') ++ args + (map (HsValArg noExtField) args') ++ args , feqn_fixity = Hs.Infix , feqn_rhs = rhs' } } _ -> failWith $ InvalidTyFamInstLHS lhs @@ -617,7 +617,7 @@ cvt_datainst_hdr cxt bndrs tys InfixT t1 nm t2 -> do { nm' <- tconNameN nm ; args' <- mapM cvtType [t1,t2] ; return (cxt', nm', outer_bndrs, - ((map HsValArg args') ++ args)) } + ((map (HsValArg noExtField) args') ++ args)) } _ -> failWith $ InvalidTypeInstanceHeader tys } ---------------- @@ -1528,8 +1528,8 @@ instance CvtFlag TH.Specificity Hs.Specificity where cvtFlag TH.InferredSpec = Hs.InferredSpec instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where - cvtFlag TH.BndrReq = HsBndrRequired - cvtFlag TH.BndrInvis = HsBndrInvisible noHsTok + cvtFlag TH.BndrReq = HsBndrRequired noExtField + cvtFlag TH.BndrInvis = HsBndrInvisible noAnn cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] cvtTvs tvs = mapM cvt_tv tvs @@ -1605,7 +1605,7 @@ cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind typeOrKind ty = do { (head_ty, tys') <- split_ty_app ty ; let m_normals = mapM extract_normal tys' - where extract_normal (HsValArg ty) = Just ty + where extract_normal (HsValArg _ ty) = Just ty extract_normal _ = Nothing ; case head_ty of @@ -1718,7 +1718,7 @@ cvtTypeKind typeOrKind ty ; ls' <- returnLA s' ; mk_apps (HsTyVar noAnn prom ls') - ([HsValArg t1', HsValArg t2'] ++ tys') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') } UInfixT t1 s t2 @@ -1734,7 +1734,7 @@ cvtTypeKind typeOrKind ty ; t2' <- cvtType t2 ; mk_apps (HsTyVar noAnn IsPromoted s') - ([HsValArg t1', HsValArg t2'] ++ tys') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') } PromotedUInfixT t1 s t2 @@ -1836,11 +1836,12 @@ mk_apps head_ty type_args = do go [] = pure head_ty' go (arg:args) = case arg of - HsValArg ty -> do p_ty <- add_parens ty + HsValArg _ ty -> + do p_ty <- add_parens ty mk_apps (HsAppTy noExtField phead_ty p_ty) args HsTypeArg at ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy noExtField phead_ty at p_ki) args + mk_apps (HsAppKindTy at phead_ty p_ki) args HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args @@ -1851,7 +1852,7 @@ mk_apps head_ty type_args = do | otherwise = return lt wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs -wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty +wrap_tyarg (HsValArg x ty) = HsValArg x $ parenthesizeHsType appPrec ty wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized @@ -1883,9 +1884,9 @@ See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where - go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } + go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg noExtField a':as') } go (AppKindT ty ki) as' = do { ki' <- cvtKind ki - ; go ty (HsTypeArg noHsTok ki' : as') } + ; go ty (HsTypeArg noAnn ki' : as') } go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -26,7 +26,8 @@ module Language.Haskell.Syntax.Type ( HsLinearArrowTokens(..), HsType(..), LHsType, HsKind, LHsKind, - HsBndrVis(..), isHsBndrInvisible, + HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis, + isHsBndrInvisible, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -38,7 +39,8 @@ module Language.Haskell.Syntax.Type ( HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsArg(..), + HsArg(..), XValArg, XTypeArg, XArgPar, XXArg, + LHsTypeArg, LBangType, BangType, @@ -66,7 +68,6 @@ import Language.Haskell.Syntax.Extension import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..) ) import GHC.Core.Type (Specificity) -import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Arity) import GHC.Hs.Doc (LHsDoc) @@ -726,19 +727,26 @@ data HsTyVarBndr flag pass !(XXTyVarBndr pass) data HsBndrVis pass - = HsBndrRequired + = HsBndrRequired !(XBndrRequired pass) -- Binder for a visible (required) variable: -- type Dup a = (a, a) -- ^^^ - | HsBndrInvisible (LHsToken "@" pass) + | HsBndrInvisible !(XBndrInvisible pass) -- Binder for an invisible (specified) variable: -- type KindOf @k (a :: k) = k -- ^^^ + | XXBndrVis !(XXBndrVis pass) + +type family XBndrRequired p +type family XBndrInvisible p +type family XXBndrVis p + isHsBndrInvisible :: HsBndrVis pass -> Bool isHsBndrInvisible HsBndrInvisible{} = True -isHsBndrInvisible HsBndrRequired = False +isHsBndrInvisible HsBndrRequired{} = False +isHsBndrInvisible (XXBndrVis _) = False -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool @@ -783,7 +791,6 @@ data HsType pass | HsAppKindTy (XAppKindTy pass) -- type level type app (LHsType pass) - !(LHsToken "@" pass) (LHsKind pass) | HsFunTy (XFunTy pass) @@ -1227,9 +1234,15 @@ do not bring any type variables into scope over the body of a function at all. -- | Arguments in an expression/type after splitting data HsArg p tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] + = HsValArg !(XValArg p) tm -- Argument is an ordinary expression (f arg) + | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty) + | HsArgPar !(XArgPar p) -- See Note [HsArgPar] + | XArg !(XXArg p) + +type family XValArg p +type family XTypeArg p +type family XArgPar p +type family XXArg p -- type level equivalent type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -90,6 +90,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { Test20239.hs:5:22-32 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -78,7 +78,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:5:10 }) @@ -265,7 +266,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:9:10 }) @@ -446,7 +448,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:13:10 }) @@ -630,7 +633,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:17:10 }) @@ -897,7 +901,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:22:10 }) @@ -951,7 +956,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:22:28 }) @@ -1091,6 +1097,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:24:11-13 }) @@ -1270,7 +1277,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:28:10 }) @@ -1324,7 +1332,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:28:28 }) @@ -1464,6 +1473,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:30:11-13 }) @@ -1643,7 +1653,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:34:10 }) @@ -1697,7 +1708,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:34:28 }) @@ -1837,6 +1849,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:36:11-13 }) @@ -2016,7 +2029,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:40:10 }) @@ -2070,7 +2084,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:40:28 }) @@ -2210,6 +2225,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:42:11-13 }) @@ -2389,7 +2405,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:46:10 }) @@ -2443,7 +2460,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:46:28 }) @@ -2583,6 +2601,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:48:11-13 }) @@ -2762,7 +2781,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:52:11 }) @@ -2816,7 +2836,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544.hs:52:30 }) @@ -2956,6 +2977,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { T17544.hs:54:12-14 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -338,7 +338,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T17544_kw.hs:21:11 }) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -358,6 +358,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:10-17 }) @@ -572,6 +573,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:12:10-12 }) @@ -640,7 +642,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:10:21-22 }) @@ -762,7 +765,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:15:8 }) @@ -787,7 +791,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:15:11 }) @@ -1182,10 +1187,8 @@ (HsOuterImplicit (NoExtField)) [(HsTypeArg - (L - (TokenLoc - (EpaSpan { DumpParsedAst.hs:19:6 })) - (HsTok)) + (EpTok + (EpaSpan { DumpParsedAst.hs:19:6 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:7-11 }) @@ -1210,6 +1213,7 @@ (Unqual {OccName: Peano}))))) ,(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:13 }) @@ -1234,6 +1238,7 @@ (Unqual {OccName: a}))))) ,(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:15 }) @@ -1284,7 +1289,8 @@ (EpaComments [])) (HsAppKindTy - (NoExtField) + (EpTok + (EpaSpan { DumpParsedAst.hs:19:21 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:19 }) @@ -1308,10 +1314,6 @@ [])) (Unqual {OccName: T})))) - (L - (TokenLoc - (EpaSpan { DumpParsedAst.hs:19:21 })) - (HsTok)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:22-26 }) @@ -1408,7 +1410,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:23 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:18:17 }) @@ -1456,7 +1459,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:40 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:18:26 }) @@ -1744,6 +1748,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:22:22-37 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -302,6 +302,7 @@ [{Name: a} ,{Name: as}]) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:10-17 }) @@ -509,6 +510,7 @@ (HsOuterImplicit []) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:14:10-12 }) @@ -569,7 +571,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:12:30 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:12:21-22 }) @@ -928,6 +931,7 @@ [{Name: a} ,{Name: k}]) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:19:22-37 }) @@ -1514,7 +1518,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:22:8 }) @@ -1538,7 +1543,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:22:17 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:22:11 }) @@ -1730,10 +1736,7 @@ [{Name: a} ,{Name: f}]) [(HsTypeArg - (L - (TokenLoc - (EpaSpan { DumpRenamedAst.hs:26:6 })) - (HsTok)) + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:26:7-11 }) @@ -1757,6 +1760,7 @@ [])) {Name: DumpRenamedAst.Peano})))) ,(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:26:13 }) @@ -1780,6 +1784,7 @@ [])) {Name: a})))) ,(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:26:15 }) @@ -1852,10 +1857,6 @@ (EpaComments [])) {Name: DumpRenamedAst.T}))) - (L - (TokenLoc - (EpaSpan { DumpRenamedAst.hs:26:21 })) - (HsTok)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:26:22-26 }) @@ -1948,7 +1949,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:23 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:25:17 }) @@ -1994,7 +1996,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:40 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:25:26 }) @@ -2321,7 +2324,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:28:9 }) @@ -2373,7 +2377,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:29:10 }) @@ -2395,7 +2400,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:29:12 }) @@ -2542,6 +2548,7 @@ (HsOuterImplicit [{Name: b}]) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:32:10-12 }) @@ -2581,6 +2588,7 @@ [])) {Name: a})))))) ,(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:32:14 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1367,7 +1367,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:38 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { DumpSemis.hs:28:24-28 }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -114,6 +114,7 @@ (HsOuterImplicit (NoExtField)) [(HsValArg + (NoExtField) (L (EpAnn (EpaSpan { KindSigs.hs:12:7 }) @@ -222,7 +223,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { KindSigs.hs:11:17 }) @@ -282,7 +284,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { KindSigs.hs:15:10 }) @@ -525,7 +528,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { KindSigs.hs:16:11 }) @@ -1499,7 +1503,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { KindSigs.hs:28:12 }) ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -73,7 +73,8 @@ [] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T15323.hs:5:19 }) ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -75,7 +75,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:5:21 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:5:15 }) @@ -190,7 +191,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:22 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:6:15 }) @@ -313,7 +315,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:26 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:8:16-18 }) @@ -361,7 +364,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:45 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:8:31-34 }) @@ -409,7 +413,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:75 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:8:50-52 }) @@ -561,7 +566,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:27 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:9:16-18 }) @@ -611,7 +617,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:46 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:9:31-34 }) @@ -661,7 +668,8 @@ ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:76 }))] (EpaComments [])) - (HsBndrRequired) + (HsBndrRequired + (NoExtField)) (L (EpAnn (EpaSpan { T20452.hs:9:50-52 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2221,9 +2221,9 @@ instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact a@(HsValArg tm) = markAnnotated tm >> return a - exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a - exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source + exact a@(HsValArg _ tm) = markAnnotated tm >> return a + exact a@(HsTypeArg at ty) = markEpToken at >> markAnnotated ty >> return a + exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source -- --------------------------------------------------------------------- @@ -3974,8 +3974,8 @@ instance ExactPrintTVFlag Specificity where instance ExactPrintTVFlag (HsBndrVis GhcPs) where exactTVDelimiters an0 bvis thing_inside = do case bvis of - HsBndrRequired -> return () - HsBndrInvisible at -> markToken at >> return () + HsBndrRequired _ -> return () + HsBndrInvisible at -> markEpToken at >> return () an1 <- markEpAnnAllL an0 lid AnnOpenP r <- thing_inside an2 <- markEpAnnAllL an1 lid AnnCloseP @@ -4012,7 +4012,7 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal getAnnotationEntry (HsTyVar an _ _) = fromAnn an getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an getAnnotationEntry (HsListTy an _) = fromAnn an getAnnotationEntry (HsTupleTy an _ _) = fromAnn an @@ -4036,7 +4036,7 @@ instance ExactPrint (HsType GhcPs) where setAnnotationAnchor a@(HsQualTy _ _ _) _ _ _s = a setAnnotationAnchor (HsTyVar an a b) anc ts cs = (HsTyVar (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a - setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _ _s = a + setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _ _s = a setAnnotationAnchor (HsFunTy an a b c) anc ts cs = (HsFunTy (setAnchorEpa an anc ts cs) a b c) setAnnotationAnchor (HsListTy an a) anc ts cs = (HsListTy (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (HsTupleTy an a b) anc ts cs = (HsTupleTy (setAnchorEpa an anc ts cs) a b) @@ -4077,11 +4077,11 @@ instance ExactPrint (HsType GhcPs) where t1' <- markAnnotated t1 t2' <- markAnnotated t2 return (HsAppTy an t1' t2') - exact (HsAppKindTy ss ty at ki) = do + exact (HsAppKindTy at ty ki) = do ty' <- markAnnotated ty - at' <- markToken at + at' <- markEpToken at ki' <- markAnnotated ki - return (HsAppKindTy ss ty' at' ki') + return (HsAppKindTy at' ty' ki') exact (HsFunTy an mult ty1 ty2) = do ty1' <- markAnnotated ty1 mult' <- markArrow mult ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit 7e8f11af63262fdc43e94059574fb1193b13e5b1 +Subproject commit ec8837db80afb9ee19cdf95e0f9ad2f37e5e6bf2 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ac43f974beaf71a56ac3bd348fb5def8ca6406a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1ac43f974beaf71a56ac3bd348fb5def8ca6406a 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 Dec 6 21:17:32 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:17:32 -0500 Subject: [Git][ghc/ghc][master] 3 commits: libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Message-ID: <6570e4ec71aed_2f7fd326e75358243149@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 5 changed files: - hadrian/src/Settings/Warnings.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs Changes: ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -35,7 +35,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" @@ -60,5 +62,7 @@ ghcWarningsArgs = do , "-Wno-redundant-constraints" , "-Wno-orphans" ] , package unix ? pure [ "-Wno-deprecations" ] - , package win32 ? pure [ "-Wno-trustworthy-safe" ] + , package win32 ? pure [ "-Wno-trustworthy-safe" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4 +Subproject commit cdb5171f7774569b1a8028a78392cfa79f732b5c ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit 5211c230903aee8c09485e8246993e2a1eb74563 +Subproject commit 0b3dbc9901fdf2d752c4ee7a7cee7b1ed20e76bd ===================================== linters/lint-submodule-refs/Main.hs ===================================== @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return True + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return False if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + ===================================== linters/linters-common/Linters/Common.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/10a1a6c635dcd8b3db5ef8bb7195717a75ebb935...86f652dc9a649e59e643609c287a510a565f5408 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/10a1a6c635dcd8b3db5ef8bb7195717a75ebb935...86f652dc9a649e59e643609c287a510a565f5408 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 Dec 6 21:18:27 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:18:27 -0500 Subject: [Git][ghc/ghc][master] Zap OccInfo on case binders during StgCse #14895 #24233 Message-ID: <6570e523b6464_2f7fd3268f52c024914b@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 7 changed files: - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - + testsuite/tests/core-to-stg/T14895.hs - + testsuite/tests/core-to-stg/T14895.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplCore/should_compile/T22309.stderr - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Stg/CSE.hs ===================================== @@ -71,6 +71,11 @@ and nothing stops us from transforming that to , Right [x] -> b} +Note that this can revive dead case binders (e.g. "b" above), hence we zap +occurrence information on all case binders during STG CSE. +See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr. + + Note [StgCse after unarisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -344,16 +349,20 @@ stgCseExpr env (StgTick tick body) = let body' = stgCseExpr env body in StgTick tick body' stgCseExpr env (StgCase scrut bndr ty alts) - = mkStgCase scrut' bndr' ty alts' + = mkStgCase scrut' bndr'' ty alts' where scrut' = stgCseExpr env scrut (env1, bndr') = substBndr env bndr + -- we must zap occurrence information on the case binder + -- because CSE might revive it. + -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr + bndr'' = zapIdOccInfo bndr' env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 -- See Note [Trivial case scrutinee] | otherwise = env1 - alts' = map (stgCseAlt env2 ty bndr') alts + alts' = map (stgCseAlt env2 ty bndr'') alts -- A constructor application. ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -446,21 +446,49 @@ calls to nonVoidIds in various places. So we must not look up Note [Dead-binder optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A case-binder, or data-constructor argument, may be marked as dead, -because we preserve occurrence-info on binders in GHC.Core.Tidy (see +Consider: + + case x of (y, z) -> rhs + +where `z` is unused in `rhs`. When we return form the eval of `x`, +GHC.StgToCmm.DataCon.bindConArgs will generate some loads, assuming the the +value of `x` is returned in R1: + y := R1[1] + z := R1[2] + +If `z` is never used, the load `z := R1[2]` is a waste of a memory operation. +CmmSink (which sinks loads to their usage sites, if any) will eliminate the dead +load; but + 1. CmmSink only runs with -O + 2. It would save CmmSink work if we simply did not generate the load in the + first place. + +Hence STG uses dead-binder information, in `bindConArgs` to drop dead loads. +That's why we preserve occurrence-info on binders in GHC.Core.Tidy (see GHC.Core.Tidy.tidyIdBndr). -If the binder is dead, we can sometimes eliminate a load. While -CmmSink will eliminate that load, it's very easy to kill it at source -(giving CmmSink less work to do), and in any case CmmSink only runs -with -O. Since the majority of case binders are dead, this -optimisation probably still has a great benefit-cost ratio and we want -to keep it for -O0. See also Phab:D5358. - -This probably also was the reason for occurrence hack in Phab:D5339 to -exist, perhaps because the occurrence information preserved by -'GHC.Core.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the -job we deleted the hacks. +So it's important that deadness is accurate. But StgCse can invalidate it +(#14895 #24233). Here is an example: + + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { + Right x -> Right (f x) + Left x -> Left x + } + + The case-binder "b" is dead (not used in the rhss of the alternatives). + StgCse notices that `Left x` doesn't need to be allocated as we can reuse `b`, + and we get: + + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { -- b no longer dead! + Right x -> Right (f x) + Left x -> b + } + +For now StgCse simply zaps occurrence information on case binders. A more +accurate update would complexify the implementation and doesn't seem worth it. + -} cgCase (StgApp v []) _ (PrimAlt _) alts ===================================== testsuite/tests/core-to-stg/T14895.hs ===================================== @@ -0,0 +1,5 @@ +module T14895 where + +go :: (a -> b) -> Either String a -> Either String b +go f (Right a) = Right (f a) +go _ (Left e) = Left e ===================================== testsuite/tests/core-to-stg/T14895.stderr ===================================== @@ -0,0 +1,20 @@ + +==================== Final STG: ==================== +T14895.go + :: forall a b. + (a -> b) + -> Data.Either.Either GHC.Base.String a + -> Data.Either.Either GHC.Base.String b +[GblId, Arity=2, Str=<1L>, Unf=OtherCon []] = + {} \r [f ds] + case ds of wild { + Data.Either.Left e [Occ=Once1] -> wild; + Data.Either.Right a1 [Occ=Once1] -> + let { + sat [Occ=Once1] :: b + [LclId] = + {a1, f} \u [] f a1; + } in Data.Either.Right [sat]; + }; + + ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -3,3 +3,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) +test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/simplCore/should_compile/T22309.stderr ===================================== @@ -9,45 +9,46 @@ $WMkW_NA :: NU_A %1 -> WNU_A = case conrep of conrep1 { __DEFAULT -> MkW_NA [conrep1]; }; $WMkW_F :: UF %1 -> WU_F = - \r [conrep] case conrep of { Mk_F us -> MkW_F [us]; }; + \r [conrep] case conrep of conrep1 { Mk_F us -> MkW_F [us]; }; $WMkW_E :: UE %1 -> WU_E = - \r [conrep] case conrep of { Mk_E us -> MkW_E [us]; }; + \r [conrep] case conrep of conrep1 { Mk_E us -> MkW_E [us]; }; $WMkW_D :: UD %1 -> WU_D = \r [conrep] - case conrep of { Mk_D unbx unbx1 -> MkW_D [unbx unbx1]; }; + case conrep of conrep1 { Mk_D unbx unbx1 -> MkW_D [unbx unbx1]; }; $WMkW_C :: UC %1 -> WU_C = - \r [conrep] case conrep of { Mk_C unbx -> MkW_C [unbx]; }; + \r [conrep] case conrep of conrep1 { Mk_C unbx -> MkW_C [unbx]; }; $WMkW_B :: UB %1 -> WU_B = - \r [conrep] case conrep of { Mk_B unbx -> MkW_B [unbx]; }; + \r [conrep] case conrep of conrep1 { Mk_B unbx -> MkW_B [unbx]; }; $WMkW_A :: UA %1 -> WU_A = - \r [conrep] case conrep of { Mk_A unbx -> MkW_A [unbx]; }; + \r [conrep] case conrep of conrep1 { Mk_A unbx -> MkW_A [unbx]; }; $WNU_MkB :: Int64 %1 -> Int64 %1 -> NU_B = \r [conrep conrep1] - case conrep of { + case conrep of conrep2 { I64# unbx -> - case conrep1 of { I64# unbx1 -> NU_MkB [unbx unbx1]; }; + case conrep1 of conrep3 { I64# unbx1 -> NU_MkB [unbx unbx1]; }; }; $WMk_D :: Int32 %1 -> Int32 %1 -> UD = \r [conrep conrep1] - case conrep of { - I32# unbx -> case conrep1 of { I32# unbx1 -> Mk_D [unbx unbx1]; }; + case conrep of conrep2 { + I32# unbx -> + case conrep1 of conrep3 { I32# unbx1 -> Mk_D [unbx unbx1]; }; }; $WMk_C :: Int32 %1 -> UC = - \r [conrep] case conrep of { I32# unbx -> Mk_C [unbx]; }; + \r [conrep] case conrep of conrep1 { I32# unbx -> Mk_C [unbx]; }; $WMk_B :: Int64 %1 -> UB = - \r [conrep] case conrep of { I64# unbx -> Mk_B [unbx]; }; + \r [conrep] case conrep of conrep1 { I64# unbx -> Mk_B [unbx]; }; $WMk_A :: Int %1 -> UA = - \r [conrep] case conrep of { I# unbx -> Mk_A [unbx]; }; + \r [conrep] case conrep of conrep1 { I# unbx -> Mk_A [unbx]; }; MkW_NB :: NU_B %1 -> WNU_B = \r [eta] case eta of eta { __DEFAULT -> MkW_NB [eta]; }; @@ -71,7 +72,8 @@ MkW_A :: Int# %1 -> WU_A = \r [eta] MkW_A [eta]; NU_MkB :: Int64# %1 -> Int64# %1 -> NU_B = \r [eta eta] NU_MkB [eta eta]; -NU_MkA :: (# Int, Int #) %1 -> NU_A = \r [us us] NU_MkA [us us]; +NU_MkA :: (# Int64, Int64 #) %1 -> NU_A = + \r [us us] NU_MkA [us us]; Mk_F :: (# Double #) %1 -> UF = \r [us] Mk_F [us]; ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b [GblId[DataConWrapper], Arity=2, Str=, Unf=OtherCon []] = {} \r [conrep conrep1] - case conrep of conrep2 [Occ=Once1] { + case conrep of conrep2 { __DEFAULT -> - case conrep1 of conrep3 [Occ=Once1] { + case conrep1 of conrep3 { __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; }; }; @@ -19,13 +19,13 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of { + case seq# [x GHC.Prim.void#] of ds1 { Solo# ipv1 [Occ=Once1] -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = {ipv1, y} \u [] - case y of conrep [Occ=Once1] { + case y of conrep { __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; }; } in seq# [sat GHC.Prim.void#]; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ac6006e42f1e1a07e86316a1e7fce74bcafae67 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7ac6006e42f1e1a07e86316a1e7fce74bcafae67 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 Dec 6 21:18:44 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 06 Dec 2023 16:18:44 -0500 Subject: [Git][ghc/ghc][master] Cpr: Turn an assertion into a check to deal with some dead code (#23862) Message-ID: <6570e5347b0dc_2f7fd326e753582507a1@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 4 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - + testsuite/tests/cpranal/should_compile/T23862.hs - + testsuite/tests/cpranal/should_compile/T23862.stderr - testsuite/tests/cpranal/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -270,11 +270,11 @@ cprAnalAlt cprAnalAlt env scrut_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where + ids = filter isId bndrs env_alt | DataAlt dc <- con - , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty - , assert (arity == 0 ) True + , arity == 0 -- See Note [Dead code may contain type confusions] = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr @@ -283,7 +283,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) | let sigs = zipWith (mkCprSig . idArity) ids field_cprs -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) | otherwise - = env + = extendSigEnvAllSame env ids topCprSig (rhs_ty, rhs') = cprAnal env_alt rhs -- @@ -430,6 +430,43 @@ cprFix orig_env orig_pairs (id', rhs', env') = cprAnalBind env id rhs {- +Note [Dead code may contain type confusions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In T23862, we have a nested case match that looks like this + + data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + data family Result (check :: Bool) a + data instance Result True a = CheckedResult a + newtype instance Result True a = UncheckedResult a + + case m () of Checked co1 -> + case m () of Unchecked co2 -> + case ((\_ -> True) + |> .. UncheckedResult .. + |> sym co2 + |> co1) :: Result True (Bool -> Bool) of + CheckedResult f -> CheckedResult (f True) + +Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` +cases are apart. +However, both constructors introduce mutually contradictory coercions `co1` and +`co2` along which GHC generates a type confusion: + + 1. (\_ -> True) :: Bool -> Bool + 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) + 3. |> ... sym co1 ... :: Result check (Bool -> Bool) + 4. |> ... co2 ... :: Result True (Bool -> Bool) + +Note that we started with a function, injected into `Result` via a newtype +instance and then match on it with a datatype instance. + +We have to handle this case gracefully in `cprAnalAlt`, where for the innermost +case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that +abstracts the function `(\_ -> True)` with arity 1. +In this case, don't pretend we know anything about the fields of `CheckedResult`! + Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: ===================================== testsuite/tests/cpranal/should_compile/T23862.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} + +module T23862 where + +data family Result (check :: Bool) a +data instance Result True a = CheckedResult a +newtype instance Result False a = UncheckedResult a + +data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + +app :: (() -> CheckSingleton check) -> Result check Bool +app m = case (m (), m ()) of + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\_ -> True) + -> CheckedResult (x True) ===================================== testsuite/tests/cpranal/should_compile/T23862.stderr ===================================== @@ -0,0 +1,18 @@ + +T23862.hs:17:12: warning: [GHC-40564] [-Winaccessible-code (in -Wdefault)] + • Inaccessible code in + a pattern with constructor: Unchecked :: CheckSingleton False, + in a case alternative + Couldn't match type ‘True’ with ‘False’ + • In the pattern: Unchecked + In the pattern: (Checked, Unchecked) + In a case alternative: + (Checked, Unchecked) + | CheckedResult x <- UncheckedResult (\ _ -> True) + -> CheckedResult (x True) + +T23862.hs:18:6: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)] + Pattern match has inaccessible right hand side + In a case alternative: + (Checked, Unchecked) | CheckedResult x <- UncheckedResult + (\ _ -> True) -> ... ===================================== testsuite/tests/cpranal/should_compile/all.T ===================================== @@ -22,3 +22,5 @@ test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsu test('T18824', [ grep_errmsg(r'JoinId[^\n]*Cpr') ], compile, ['-ddump-exitify -dppr-cols=1000 -dsuppress-uniques']) test('T20539', [], compile, ['']) # simply should not crash + +test('T23862', [], compile, ['']) # simply should not crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57c391c463f26b7025df9b340ad98416cff1d2b2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57c391c463f26b7025df9b340ad98416cff1d2b2 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 Dec 6 21:19:08 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 16:19:08 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6570e54c629da_2f7fd326e753582529d5@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: ffb5af62 by Oleg Grenrus at 2023-12-06T23:18:19+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 5 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +73,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +94,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +-- PackageImports can be removed once base's GHC.TypeLits.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +334,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +368,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +412,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +448,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +-- PackageImports can be removed once base's GHC.TypeNats.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +338,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +374,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ffb5af621e03df031e414ebfc577e92f2545ef59 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ffb5af621e03df031e414ebfc577e92f2545ef59 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 Dec 6 23:24:04 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 06 Dec 2023 18:24:04 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken in HsArrow Message-ID: <65710294b611a_15317718c40dc4045f@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 37745170 by Vladislav Zavialov at 2023-12-07T02:23:55+03:00 EPA: use EpToken in HsArrow - - - - - 30 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/printer/T18791.stderr - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37745170eea26fb895c042590335f41290b5d650 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37745170eea26fb895c042590335f41290b5d650 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 Dec 7 00:44:45 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Wed, 06 Dec 2023 19:44:45 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <6571157d530ff_153177a0cbc43926@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: 4a8d3c51 by Oleg Grenrus at 2023-12-07T02:43:05+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 11 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - + libraries/ghc-internal/src/GHC/TypeLits/Internal.hs - + libraries/ghc-internal/src/GHC/TypeNats/Internal.hs - testsuite/tests/ghci/scripts/T9181.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/plugins/plugins09.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/plugins11.stdout - testsuite/tests/plugins/static-plugins.stdout Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -12,11 +12,15 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +73,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +94,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +-- PackageImports can be removed once base's GHC.TypeLits.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeLits.Internal + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +334,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +368,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +412,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +448,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -14,10 +14,14 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +71,11 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +-- PackageImports can be removed once base's GHC.TypeNats.Internal +-- is hidden and renamed +-- https://github.com/haskell/core-libraries-committee/issues/217 +import "ghc-internal" GHC.TypeNats.Internal + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +338,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +374,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.TypeLits.Internal + GHC.TypeNats.Internal build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/GHC/TypeLits/Internal.hs ===================================== @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeLits.Internal ( + SChar (..), + SSymbol (..), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar Char +type role SChar nominal + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol [Char] +type role SSymbol nominal + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/TypeNats/Internal.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +module GHC.TypeNats.Internal ( + SNat (..), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat Natural +type role SNat nominal + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ ===================================== testsuite/tests/ghci/scripts/T9181.stdout ===================================== @@ -8,24 +8,24 @@ type GHC.TypeLits.ConsSymbol :: Char type family GHC.TypeLits.ConsSymbol a b type GHC.TypeLits.KnownChar :: Char -> Constraint class GHC.TypeLits.KnownChar n where - GHC.TypeLits.charSing :: GHC.TypeLits.SChar n + GHC.TypeLits.charSing :: ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar + n {-# MINIMAL charSing #-} type GHC.TypeLits.KnownSymbol :: GHC.Types.Symbol -> Constraint class GHC.TypeLits.KnownSymbol n where - GHC.TypeLits.symbolSing :: GHC.TypeLits.SSymbol n + GHC.TypeLits.symbolSing :: ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol + n {-# MINIMAL symbolSing #-} type GHC.TypeLits.NatToChar :: GHC.Num.Natural.Natural -> Char type family GHC.TypeLits.NatToChar a pattern GHC.TypeLits.SChar - :: () => GHC.TypeLits.KnownChar c => GHC.TypeLits.SChar c -type role GHC.TypeLits.SChar nominal -type GHC.TypeLits.SChar :: Char -> * -newtype GHC.TypeLits.SChar s = GHC.TypeLits.UnsafeSChar Char + :: () => + GHC.TypeLits.KnownChar c => + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c pattern GHC.TypeLits.SSymbol - :: () => GHC.TypeLits.KnownSymbol s => GHC.TypeLits.SSymbol s -type role GHC.TypeLits.SSymbol nominal -type GHC.TypeLits.SSymbol :: GHC.Types.Symbol -> * -newtype GHC.TypeLits.SSymbol s = GHC.TypeLits.UnsafeSSymbol String + :: () => + GHC.TypeLits.KnownSymbol s => + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s type GHC.TypeLits.SomeChar :: * data GHC.TypeLits.SomeChar = forall (n :: Char). @@ -62,9 +62,12 @@ GHC.TypeLits.decideSymbol :: -> Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) -GHC.TypeLits.fromSChar :: GHC.TypeLits.SChar c -> Char -GHC.TypeLits.fromSNat :: GHC.TypeNats.SNat n -> Integer -GHC.TypeLits.fromSSymbol :: GHC.TypeLits.SSymbol s -> String +GHC.TypeLits.fromSChar :: + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c -> Char +GHC.TypeLits.fromSNat :: + ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n -> Integer +GHC.TypeLits.fromSSymbol :: + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s -> String GHC.TypeLits.natVal :: GHC.TypeNats.KnownNat n => proxy n -> Integer GHC.TypeLits.natVal' :: @@ -83,19 +86,25 @@ GHC.TypeLits.symbolVal :: GHC.TypeLits.symbolVal' :: GHC.TypeLits.KnownSymbol n => GHC.Prim.Proxy# n -> String GHC.TypeLits.withKnownChar :: - GHC.TypeLits.SChar c -> (GHC.TypeLits.KnownChar c => r) -> r + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c + -> (GHC.TypeLits.KnownChar c => r) -> r GHC.TypeLits.withKnownSymbol :: - GHC.TypeLits.SSymbol s -> (GHC.TypeLits.KnownSymbol s => r) -> r + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s + -> (GHC.TypeLits.KnownSymbol s => r) -> r GHC.TypeLits.withSomeSChar :: - Char -> (forall (c :: Char). GHC.TypeLits.SChar c -> r) -> r + Char + -> (forall (c :: Char). + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c -> r) + -> r GHC.TypeLits.withSomeSNat :: Integer - -> (forall (n :: GHC.TypeNats.Nat). - Maybe (GHC.TypeNats.SNat n) -> r) + -> (forall (n :: GHC.Num.Natural.Natural). + Maybe (ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n) -> r) -> r GHC.TypeLits.withSomeSSymbol :: String - -> (forall (s :: GHC.Types.Symbol). GHC.TypeLits.SSymbol s -> r) + -> (forall (s :: GHC.Types.Symbol). + ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s -> r) -> r type (GHC.TypeNats.*) :: GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural @@ -115,14 +124,15 @@ type (Data.Type.Ord.<=?) :: forall k. k -> k -> Bool type (Data.Type.Ord.<=?) m n = Data.Type.Ord.OrdCond (Data.Type.Ord.Compare m n) True True False :: Bool -type GHC.TypeLits.Internal.CmpChar :: Char -> Char -> Ordering -type family GHC.TypeLits.Internal.CmpChar a b -type GHC.TypeNats.Internal.CmpNat :: GHC.Num.Natural.Natural - -> GHC.Num.Natural.Natural -> Ordering -type family GHC.TypeNats.Internal.CmpNat a b -type GHC.TypeLits.Internal.CmpSymbol :: GHC.Types.Symbol - -> GHC.Types.Symbol -> Ordering -type family GHC.TypeLits.Internal.CmpSymbol a b +type base-4.19.0.0:GHC.TypeLits.Internal.CmpChar :: Char + -> Char -> Ordering +type family base-4.19.0.0:GHC.TypeLits.Internal.CmpChar a b +type base-4.19.0.0:GHC.TypeNats.Internal.CmpNat :: GHC.Num.Natural.Natural + -> GHC.Num.Natural.Natural -> Ordering +type family base-4.19.0.0:GHC.TypeNats.Internal.CmpNat a b +type base-4.19.0.0:GHC.TypeLits.Internal.CmpSymbol :: GHC.Types.Symbol + -> GHC.Types.Symbol -> Ordering +type family base-4.19.0.0:GHC.TypeLits.Internal.CmpSymbol a b type GHC.TypeNats.Div :: GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural type family GHC.TypeNats.Div a b @@ -138,7 +148,8 @@ data GHC.TypeError.ErrorMessage GHC.TypeError.ErrorMessage type GHC.TypeNats.KnownNat :: GHC.TypeNats.Nat -> Constraint class GHC.TypeNats.KnownNat n where - GHC.TypeNats.natSing :: GHC.TypeNats.SNat n + GHC.TypeNats.natSing :: ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat + n {-# MINIMAL natSing #-} type GHC.TypeNats.Log2 :: GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural @@ -164,12 +175,24 @@ data Data.Type.Ord.OrderingI a b where Data.Type.Ord.GTI :: forall {k} (a :: k) (b :: k). (Data.Type.Ord.Compare a b ~ GT) => Data.Type.Ord.OrderingI a b +type role ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar nominal +type ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar :: Char -> * +newtype ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar s + = ghc-internal-0.1.0.0:GHC.TypeLits.Internal.UnsafeSChar Char pattern GHC.TypeNats.SNat - :: () => GHC.TypeNats.KnownNat n => GHC.TypeNats.SNat n -type role GHC.TypeNats.SNat nominal -type GHC.TypeNats.SNat :: GHC.TypeNats.Nat -> * -newtype GHC.TypeNats.SNat n - = GHC.TypeNats.UnsafeSNat GHC.Num.Natural.Natural + :: () => + GHC.TypeNats.KnownNat n => + ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n +type role ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat nominal +type ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat :: GHC.Num.Natural.Natural + -> * +newtype ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n + = ghc-internal-0.1.0.0:GHC.TypeNats.Internal.UnsafeSNat GHC.Num.Natural.Natural +type role ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol nominal +type ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol :: GHC.Types.Symbol + -> * +newtype ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s + = ghc-internal-0.1.0.0:GHC.TypeLits.Internal.UnsafeSSymbol [Char] type GHC.TypeNats.SomeNat :: * data GHC.TypeNats.SomeNat = forall (n :: GHC.TypeNats.Nat). @@ -197,4 +220,5 @@ GHC.TypeNats.sameNat :: (GHC.TypeNats.KnownNat a, GHC.TypeNats.KnownNat b) => proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) GHC.TypeNats.withKnownNat :: - GHC.TypeNats.SNat n -> (GHC.TypeNats.KnownNat n => r) -> r + ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n + -> (GHC.TypeNats.KnownNat n => r) -> r ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -9462,7 +9462,7 @@ module GHC.TypeLits where newtype SChar s = ... pattern SNat :: forall (n :: Nat). () => KnownNat n => SNat n type role SNat nominal - type SNat :: Nat -> * + type SNat :: Natural -> * newtype SNat n = ... pattern SSymbol :: forall (s :: Symbol). () => KnownSymbol s => SSymbol s type role SSymbol nominal @@ -9491,7 +9491,7 @@ module GHC.TypeLits where decideNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) decideSymbol :: forall (a :: Symbol) (b :: Symbol) (proxy1 :: Symbol -> *) (proxy2 :: Symbol -> *). (KnownSymbol a, KnownSymbol b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) fromSChar :: forall (c :: GHC.Types.Char). SChar c -> GHC.Types.Char - fromSNat :: forall (n :: Nat). SNat n -> GHC.Num.Integer.Integer + fromSNat :: forall (n :: Natural). SNat n -> GHC.Num.Integer.Integer fromSSymbol :: forall (s :: Symbol). SSymbol s -> GHC.Base.String natVal :: forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> GHC.Num.Integer.Integer natVal' :: forall (n :: Nat). KnownNat n => GHC.Prim.Proxy# n -> GHC.Num.Integer.Integer @@ -9504,10 +9504,10 @@ module GHC.TypeLits where symbolVal :: forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> GHC.Base.String symbolVal' :: forall (n :: Symbol). KnownSymbol n => GHC.Prim.Proxy# n -> GHC.Base.String withKnownChar :: forall (c :: GHC.Types.Char) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SChar c -> (KnownChar c => r) -> r - withKnownNat :: forall (n :: Nat) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r + withKnownNat :: forall (n :: Natural) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withKnownSymbol :: forall (s :: Symbol) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SSymbol s -> (KnownSymbol s => r) -> r withSomeSChar :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Types.Char -> (forall (c :: GHC.Types.Char). SChar c -> r) -> r - withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Num.Integer.Integer -> (forall (n :: Nat). GHC.Maybe.Maybe (SNat n) -> r) -> r + withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Num.Integer.Integer -> (forall (n :: Natural). GHC.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r module GHC.TypeLits.Internal where @@ -9549,7 +9549,7 @@ module GHC.TypeNats where data Natural = ... pattern SNat :: forall (n :: Nat). () => KnownNat n => SNat n type role SNat nominal - type SNat :: Nat -> * + type SNat :: Natural -> * newtype SNat n = ... type SomeNat :: * data SomeNat = forall (n :: Nat). KnownNat n => SomeNat (Data.Proxy.Proxy n) @@ -9557,13 +9557,13 @@ module GHC.TypeNats where type family (^) a b cmpNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Type.Ord.OrderingI a b decideNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) - fromSNat :: forall (n :: Nat). SNat n -> Natural + fromSNat :: forall (n :: Natural). SNat n -> Natural natVal :: forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Natural natVal' :: forall (n :: Nat). KnownNat n => GHC.Prim.Proxy# n -> Natural sameNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> GHC.Maybe.Maybe (a Data.Type.Equality.:~: b) someNatVal :: Natural -> SomeNat - withKnownNat :: forall (n :: Nat) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r - withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r + withKnownNat :: forall (n :: Natural) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r + withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Natural). SNat n -> r) -> r module GHC.TypeNats.Internal where -- Safety: Trustworthy @@ -11014,15 +11014,15 @@ instance Data.Traversable.Traversable Data.Semigroup.First -- Defined in ‘Data instance Data.Traversable.Traversable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance Data.Traversable.Traversable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance Data.Traversable.Traversable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance Data.Type.Coercion.TestCoercion GHC.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Coercion.TestCoercion GHC.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Coercion.TestCoercion GHC.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ +instance Data.Type.Coercion.TestCoercion ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Coercion.TestCoercion ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Coercion.TestCoercion ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat -- Defined in ‘GHC.TypeNats’ instance forall k (a :: k). Data.Type.Coercion.TestCoercion ((Data.Type.Equality.:~:) a) -- Defined in ‘Data.Type.Coercion’ instance forall k1 k (a :: k1). Data.Type.Coercion.TestCoercion ((Data.Type.Equality.:~~:) a) -- Defined in ‘Data.Type.Coercion’ instance forall k (a :: k). Data.Type.Coercion.TestCoercion (Data.Type.Coercion.Coercion a) -- Defined in ‘Data.Type.Coercion’ -instance Data.Type.Equality.TestEquality GHC.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Equality.TestEquality GHC.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Equality.TestEquality GHC.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ +instance Data.Type.Equality.TestEquality ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Equality.TestEquality ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Equality.TestEquality ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat -- Defined in ‘GHC.TypeNats’ instance forall k (a :: k). Data.Type.Equality.TestEquality ((Data.Type.Equality.:~:) a) -- Defined in ‘Data.Type.Equality’ instance forall k1 k (a :: k1). Data.Type.Equality.TestEquality ((Data.Type.Equality.:~~:) a) -- Defined in ‘Data.Type.Equality’ instance forall k. Data.Type.Equality.TestEquality base-4.19.0.0:Data.Typeable.Internal.TypeRep -- Defined in ‘base-4.19.0.0:Data.Typeable.Internal’ @@ -12076,11 +12076,11 @@ instance GHC.Show.Show GHC.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Stac instance GHC.Show.Show GHC.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.StaticPtr’ instance GHC.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance GHC.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ -instance forall (c :: GHC.Types.Char). GHC.Show.Show (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Show.Show (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ +instance forall (c :: GHC.Types.Char). GHC.Show.Show (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c) -- Defined in ‘GHC.TypeLits’ +instance forall (s :: GHC.Types.Symbol). GHC.Show.Show (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Show.Show GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Show.Show GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Show.Show (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Show.Show (ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Show.Show GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ instance [safe] GHC.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’ instance GHC.Show.Show Text.Read.Lex.Lexeme -- Defined in ‘Text.Read.Lex’ @@ -12267,12 +12267,12 @@ instance GHC.Classes.Eq GHC.Num.BigNat.BigNat -- Defined in ‘GHC.Num.BigNat’ instance GHC.Classes.Eq GHC.Num.Natural.Natural -- Defined in ‘GHC.Num.Natural’ instance forall a. GHC.Classes.Eq (GHC.StableName.StableName a) -- Defined in ‘GHC.StableName’ instance GHC.Classes.Eq GHC.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Stack.CloneStack’ -instance forall (c :: GHC.Types.Char). GHC.Classes.Eq (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Classes.Eq (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Eq GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Eq GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Classes.Eq (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Classes.Eq GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ +instance forall (c :: GHC.Types.Char). GHC.Classes.Eq (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeLits.Internal’ +instance forall (s :: GHC.Types.Symbol). GHC.Classes.Eq (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeLits.Internal’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Classes.Eq (ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeNats.Internal’ instance [safe] GHC.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’ instance GHC.Classes.Eq Text.Read.Lex.Lexeme -- Defined in ‘Text.Read.Lex’ instance GHC.Classes.Eq Text.Read.Lex.Number -- Defined in ‘Text.Read.Lex’ @@ -12394,9 +12394,9 @@ instance GHC.Classes.Ord GHC.IO.IOMode.IOMode -- Defined in ‘GHC.IO.IOMode’ instance GHC.Classes.Ord GHC.Num.Integer.Integer -- Defined in ‘GHC.Num.Integer’ instance GHC.Classes.Ord GHC.Num.BigNat.BigNat -- Defined in ‘GHC.Num.BigNat’ instance GHC.Classes.Ord GHC.Num.Natural.Natural -- Defined in ‘GHC.Num.Natural’ -instance forall (c :: GHC.Types.Char). GHC.Classes.Ord (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Classes.Ord (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Ord GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Ord GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Classes.Ord (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Classes.Ord GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ +instance forall (c :: GHC.Types.Char). GHC.Classes.Ord (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SChar c) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeLits.Internal’ +instance forall (s :: GHC.Types.Symbol). GHC.Classes.Ord (ghc-internal-0.1.0.0:GHC.TypeLits.Internal.SSymbol s) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeLits.Internal’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Classes.Ord (ghc-internal-0.1.0.0:GHC.TypeNats.Internal.SNat n) -- Defined in ‘ghc-internal-0.1.0.0:GHC.TypeNats.Internal’ ===================================== testsuite/tests/plugins/plugins09.stdout ===================================== @@ -2,6 +2,8 @@ parsePlugin(a,b) interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) typeCheckPlugin (tc) ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -4,6 +4,8 @@ interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext interfacePlugin: Language.Haskell.TH.Syntax typeCheckPlugin (rn) ===================================== testsuite/tests/plugins/plugins11.stdout ===================================== @@ -2,6 +2,8 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) typeCheckPlugin (tc) ===================================== testsuite/tests/plugins/static-plugins.stdout ===================================== @@ -3,6 +3,8 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext interfacePlugin: System.IO interfacePlugin: GHC.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a8d3c5178171a89e61ba145b166dc072df4328b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a8d3c5178171a89e61ba145b166dc072df4328b 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 Dec 7 08:21:21 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 07 Dec 2023 03:21:21 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: Only exit ghci in -e mode when :add command fails Message-ID: <65718081cebac_153177e4b8530722c0@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - a7088181 by Zubin Duggal at 2023-12-07T03:21:14-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 - - - - - 7f049697 by Wendao Lee at 2023-12-07T03:21:17-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> - - - - - 30 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Warnings.hs - libraries/base/src/GHC/Unicode.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - testsuite/tests/ado/T22483.stderr - + testsuite/tests/core-to-stg/T14895.hs - + testsuite/tests/core-to-stg/T14895.stderr - testsuite/tests/core-to-stg/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a009236cb9c6a816d516a1c9290ae7009a644c2...7f049697f637ac27dc64bcaf6d0df1399dfae49a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a009236cb9c6a816d516a1c9290ae7009a644c2...7f049697f637ac27dc64bcaf6d0df1399dfae49a 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 Dec 7 08:50:12 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 07 Dec 2023 03:50:12 -0500 Subject: [Git][ghc/ghc][wip/24107] compiler: Force IfGlobalRdrEnv in NFData instance. Message-ID: <657187441803e_153177f5b1f44773ef@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 23f9dd2b by Zubin Duggal at 2023-12-07T14:19:33+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 2 changed files: - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs Changes: ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -574,6 +574,9 @@ data GlobalRdrEltX info -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -625,13 +628,17 @@ instance NFData IfGlobalRdrElt where -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -934,11 +941,10 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- Also forces the bag in gre_imp. -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> rnf (gre_imp gre) `seq` gre { gre_info = ()})) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -575,11 +575,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23f9dd2b9768ee2dc7a4dd5c4d90c04d1405f164 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/23f9dd2b9768ee2dc7a4dd5c4d90c04d1405f164 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 Dec 7 08:51:21 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 07 Dec 2023 03:51:21 -0500 Subject: [Git][ghc/ghc][wip/24107] compiler: Force IfGlobalRdrEnv in NFData instance. Message-ID: <6571878951a8e_153177f57cc68779ae@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 59e7b766 by Zubin Duggal at 2023-12-07T14:21:14+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 2 changed files: - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs Changes: ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -574,6 +574,9 @@ data GlobalRdrEltX info -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -620,18 +623,19 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where - rnf !_ = () - -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -934,11 +938,10 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- Also forces the bag in gre_imp. -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> rnf (gre_imp gre) `seq` gre { gre_info = ()})) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -575,11 +575,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59e7b76695677b6173d2cbd5b8a8b14dcfcf4842 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/59e7b76695677b6173d2cbd5b8a8b14dcfcf4842 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 Dec 7 10:20:52 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 07 Dec 2023 05:20:52 -0500 Subject: [Git][ghc/ghc][wip/24107] 5 commits: driver: Ensure we actually clear the interactive context before reloading Message-ID: <65719c848118a_153177118fa12c9161e@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 74d501df by Zubin Duggal at 2023-12-07T15:50:40+05:30 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 - - - - - 3d31d770 by Zubin Duggal at 2023-12-07T15:50:40+05:30 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 - - - - - c7f64bcb by Zubin Duggal at 2023-12-07T15:50:40+05:30 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 - - - - - b11fcbd3 by Zubin Duggal at 2023-12-07T15:50:40+05:30 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 - - - - - adb8aecd by Zubin Duggal at 2023-12-07T15:50:40+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 9 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Data/Bag.hs ===================================== @@ -40,6 +40,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq infixr 3 `consBag` infixl 3 `snocBag` @@ -51,6 +52,12 @@ data Bag a | ListBag (NonEmpty a) deriving (Foldable, Functor, Traversable) +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a + emptyBag :: Bag a emptyBag = EmptyBag ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -771,6 +771,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env + hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env @@ -780,7 +781,6 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do worker_limit <- liftIO $ mkWorkerLimit dflags - setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -574,6 +574,9 @@ data GlobalRdrEltX info -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -620,18 +623,19 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where - rnf !_ = () - -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -934,11 +938,10 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. @@ -1916,25 +1919,28 @@ instance Semigroup ShadowedGREs where -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1945,8 +1951,8 @@ data ImpItemSpec -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -575,11 +575,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules ===================================== testsuite/tests/ghci/T23405/T23405.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23405 (test) where + +import Language.Haskell.TH + +test :: IO () +test = do + let s = $(getDoc (DeclDoc ''Double) >>= \doc -> [|doc|]) + print (s `seq` ()) + + ===================================== testsuite/tests/ghci/T23405/T23405.script ===================================== @@ -0,0 +1,3 @@ +:load T23405.hs +:! echo "-- an extra comment so that the hash changes" >> T23405.hs +:reload ===================================== testsuite/tests/ghci/T23405/all.T ===================================== @@ -0,0 +1 @@ +test('T23405', [extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -391,6 +391,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefs'), + extra_files(['genMultiLayerModulesDefs']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59e7b76695677b6173d2cbd5b8a8b14dcfcf4842...adb8aecd2934ad0cd50dea50c6710fe4f86bc2bf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59e7b76695677b6173d2cbd5b8a8b14dcfcf4842...adb8aecd2934ad0cd50dea50c6710fe4f86bc2bf 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 Dec 7 13:21:36 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 07 Dec 2023 08:21:36 -0500 Subject: [Git][ghc/ghc][wip/24107] 5 commits: driver: Ensure we actually clear the interactive context before reloading Message-ID: <6571c6e0c029f_15317715d12c741075c1@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 64a3911f by Zubin Duggal at 2023-12-07T18:51:25+05:30 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 - - - - - 819f3ee8 by Zubin Duggal at 2023-12-07T18:51:25+05:30 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 - - - - - 419a8836 by Zubin Duggal at 2023-12-07T18:51:25+05:30 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 - - - - - c719b909 by Zubin Duggal at 2023-12-07T18:51:25+05:30 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 - - - - - fd0db14c by Zubin Duggal at 2023-12-07T18:51:25+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 9 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Data/Bag.hs ===================================== @@ -40,6 +40,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq infixr 3 `consBag` infixl 3 `snocBag` @@ -51,6 +52,12 @@ data Bag a | ListBag (NonEmpty a) deriving (Foldable, Functor, Traversable) +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a + emptyBag :: Bag a emptyBag = EmptyBag ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -771,6 +771,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env + hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env @@ -780,7 +781,6 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do worker_limit <- liftIO $ mkWorkerLimit dflags - setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -574,6 +574,9 @@ data GlobalRdrEltX info -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -620,18 +623,19 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where - rnf !_ = () - -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -934,11 +938,10 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. @@ -1916,25 +1919,28 @@ instance Semigroup ShadowedGREs where -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1945,8 +1951,8 @@ data ImpItemSpec -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -575,11 +575,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules ===================================== testsuite/tests/ghci/T23405/T23405.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23405 (test) where + +import Language.Haskell.TH + +test :: IO () +test = do + let s = $(getDoc (DeclDoc ''Double) >>= \doc -> [|doc|]) + print (s `seq` ()) + + ===================================== testsuite/tests/ghci/T23405/T23405.script ===================================== @@ -0,0 +1,3 @@ +:load T23405.hs +:! echo -- an extra comment so that the hash changes >> T23405.hs +:reload ===================================== testsuite/tests/ghci/T23405/all.T ===================================== @@ -0,0 +1 @@ +test('T23405', [extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -391,6 +391,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefs'), + extra_files(['genMultiLayerModulesDefs']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/adb8aecd2934ad0cd50dea50c6710fe4f86bc2bf...fd0db14c439d7dbacc39e0ec9e932eaea1993228 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/adb8aecd2934ad0cd50dea50c6710fe4f86bc2bf...fd0db14c439d7dbacc39e0ec9e932eaea1993228 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 Dec 7 13:32:35 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 07 Dec 2023 08:32:35 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Improve duplicate elimination in SpecConstr Message-ID: <6571c97368f95_153177161c41dc1129b5@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 49a396d5 by Simon Peyton Jones at 2023-12-07T08:32:01-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - 0e059b1a by Simon Peyton Jones at 2023-12-07T08:32:01-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] - - - - - 18696809 by Zubin Duggal at 2023-12-07T08:32:02-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 - - - - - 4ab87daf by Zubin Duggal at 2023-12-07T08:32:02-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 9af3df67 by Wendao Lee at 2023-12-07T08:32:05-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> - - - - - 24 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Tc/Utils/TcType.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/perf/compiler/all.T - + testsuite/tests/simplCore/should_compile/T23209.hs - + testsuite/tests/simplCore/should_compile/T23209_Aux.hs - + testsuite/tests/simplCore/should_compile/T24229a.hs - + testsuite/tests/simplCore/should_compile/T24229a.stderr - + testsuite/tests/simplCore/should_compile/T24229b.hs - + testsuite/tests/simplCore/should_compile/T24229b.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -1237,9 +1237,8 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca -} getSubst :: SimplEnv -> Subst -getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkSubst in_scope tv_env cv_env emptyIdSubstEnv +getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = mkTCvSubst in_scope tv_env cv_env substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getSubst env) ty ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) -import GHC.Data.Pair import GHC.Data.FastString import GHC.Utils.Misc @@ -81,8 +80,8 @@ import GHC.Builtin.Names ( specTyConKey ) import GHC.Exts( SpecConstrAnnotation(..) ) import GHC.Serialized ( deserializeWithData ) -import Control.Monad ( zipWithM ) -import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) +import Control.Monad +import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL ) import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) import Data.Tuple @@ -2246,7 +2245,7 @@ Wrinkles: * The list of argument patterns, cp_args, is no longer than the visible lambdas of the binding, ri_arg_occs. This is done via - the zipWithM in callToPats. + the zipWithM in callToPat. * The list of argument patterns can certainly be shorter than the lambdas in the function definition (under-saturated). For example @@ -2256,7 +2255,7 @@ Wrinkles: * In fact we deliberately shrink the list of argument patterns, cp_args, by trimming off all the boring ones at the end (see - `dropWhileEnd is_boring` in callToPats). Since the RULE only + `dropWhileEnd is_boring` in callToPat). Since the RULE only applies when it is saturated, this shrinking makes the RULE more applicable. But it does mean that the argument patterns do not necessarily saturate the lambdas of the function. @@ -2299,63 +2298,48 @@ Note [SpecConstr and casts] Consider (#14270) a call like let f = e - in ... f (K @(a |> co)) ... + in ... f (K @(a |> cv)) ... -where 'co' is a coercion variable not in scope at f's definition site. +where 'cv' is a coercion variable not in scope at f's definition site. If we aren't careful we'll get - let $sf a co = e (K @(a |> co)) - RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co + let $sf a cv = e (K @(a |> cv)) + RULE "SC:f" forall a cv. f (K @(a |> cv)) = $sf a co f = e in ... -But alas, when we match the call we won't bind 'co', because type-matching -(for good reasons) discards casts). - -I don't know how to solve this, so for now I'm just discarding any -call patterns that - * Mentions a coercion variable in a type argument - * That is not in scope at the binding of the function - -I think this is very rare. - -It is important (e.g. #14936) that this /only/ applies to -coercions mentioned in casts. We don't want to be discombobulated -by casts in terms! For example, consider - f ((e1,e2) |> sym co) -where, say, - f :: Foo -> blah - co :: Foo ~R (Int,Int) - -Here we definitely do want to specialise for that pair! We do not -match on the structure of the coercion; instead we just match on a -coercion variable, so the RULE looks like - - forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) - f ((x,y) |> co) = $sf x y co - -Often the body of f looks like - f arg = ...(case arg |> co' of - (x,y) -> blah)... - -so that the specialised f will turn into - $sf x y co = let arg = (x,y) |> co - in ...(case arg>| co' of - (x,y) -> blah).... - -which will simplify to not use 'co' at all. But we can't guarantee -that co will end up unused, so we still pass it. Absence analysis -may remove it later. - -Note that this /also/ discards the call pattern if we have a cast in a -/term/, although in fact Rules.match does make a very flaky and -fragile attempt to match coercions. e.g. a call like - f (Maybe Age) (Nothing |> co) blah - where co :: Maybe Int ~ Maybe Age -will be discarded. It's extremely fragile to match on the form of a -coercion, so I think it's better just not to try. A more complicated -alternative would be to discard calls that mention coercion variables -only in kind-casts, but I'm doing the simple thing for now. +But alas, when we match the call we may fail to bind 'co', because the rule +matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear +in casts (see Note [Casts in the template] in GHC.Core.Rules). + +This seems intractable (see #23209). So: + +* Key point: we /never/ quantify over coercion variables in a SpecConstr rule. + If we would need to quantify over a coercion variable, we just discard the + call pattern. See the test for `bad_covars` in callToPat. + +* However (#14936) we /do/ still allow casts in call patterns. For example + f ((e1,e2) |> sym co) + where, say, + f :: Foo -> blah -- Foo is a newtype + f = f_rhs + co :: Foo ~R (Int,Int) + We want to specialise on that pair! + +So for our function f, we might generate + RULE forall x y. f ((x,y) |> co) = $sf x y + $sf x y = f_rhs ((x,y) |> co) + +This works provided the free vars of `co` are either in-scope at the +definition of `f`, or quantified. For the latter, suppose `f` was polymorphic: + + f2 :: Foo2 a -> blah -- Foo is a newtype + f2 = f2_rhs + co2 :: Foo a ~R (a,a) + +Then it's fine for `co2` to mention `a`. We'll get + RULE forall a (x::a) (y::a). f2 @a ((x,y) |> co2) = $sf2 a x y + $sf2 @a x y = f2_rhs ((x,y) |> co2) -} data CallPat = CP { cp_qvars :: [Var] -- Quantified variables @@ -2381,19 +2365,23 @@ callsToNewPats :: ScEnv -> Id -- The "New" in the name means "patterns that are not already covered -- by an existing specialisation" callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls + = do { mb_pats <- mapM (callToPat env bndr_occs) calls ; let have_boring_call = any isNothing mb_pats good_pats :: [CallPat] good_pats = catMaybes mb_pats + in_scope = getSubstInScope (sc_subst env) + -- Remove patterns we have already done new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs + is_done p = any is_better done_specs + where + is_better done = betterPat in_scope (os_pat done) p -- Remove duplicates - non_dups = nubBy samePat new_pats + non_dups = subsumePats in_scope new_pats -- Remove ones that have too many worker variables small_pats = filterOut too_many_worker_args non_dups @@ -2410,6 +2398,10 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats -- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "good_pats:" <+> ppr good_pats +-- , text "new_pats:" <+> ppr new_pats +-- , text "non_dups:" <+> ppr non_dups +-- , text "small_pats:" <+> ppr small_pats -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "trimmed_pats:" <+> ppr trimmed_pats ]) @@ -2477,12 +2469,12 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) +callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- The [Var] is the variables to quantify over in the rule -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call fn args con_env) +callToPat env bndr_occs call@(Call fn args con_env) = do { let in_scope = getSubstInScope (sc_subst env) ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) @@ -2513,32 +2505,25 @@ callToPats env bndr_occs call@(Call fn args con_env) -- See Note [Free type variables of the qvar types] -- See Note [Shadowing] at the top - (ktvs, ids) = partition isTyVar qvars - qvars' = scopedSort ktvs ++ map sanitise ids + (qktvs, qids) = partition isTyVar qvars + qvars' = scopedSort qktvs ++ map sanitise qids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = updateIdTypeAndMult expandTypeSynonyms id + sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] - -- Check for bad coercion variables: see Note [SpecConstr and casts] - ; let bad_covars :: CoVarSet - bad_covars = mapUnionVarSet get_bad_covars pats - get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty) - get_bad_covars _ = emptyVarSet - bad_covar v = isId v && not (is_in_scope v) - - ; warnPprTrace (not (isEmptyVarSet bad_covars)) + ; let bad_covars = filter isCoVar qids + ; warnPprTrace (not (null bad_covars)) "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ - if interesting && isEmptyVarSet bad_covars + if interesting && null bad_covars then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats , cp_strict_args = concat cbv_ids } --- ; pprTraceM "callToPatsOut" $ +-- ; pprTraceM "callToPatOut" $ -- vcat [ text "fn:" <+> ppr fn -- , text "args:" <+> ppr args -- , text "bndr_occs:" <+> ppr bndr_occs @@ -2606,39 +2591,16 @@ argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str -- Here we can specialise for f (v,w) -- because the rule-matcher will look through the let. -{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" - = argToPat env in_scope val_env rhs arg_occ --} - + -- Casts: see Note [SpecConstr and casts] argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str ; if not interesting then wildCardPat ty2 arg_str - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } } + else + return (interesting, Cast arg' co, strict_args) } where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) - where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} + ty2 = coercionRKind co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs @@ -2727,6 +2689,25 @@ argToPat1 env in_scope val_env (Var v) arg_occ arg_str -- f x y = letrec g z = ... in g (x,y) -- We don't want to specialise for that *particular* x,y + +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + = argToPat env in_scope val_env rhs arg_occ +-} + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + -- The default case: make a wild-card -- We use this for coercions too argToPat1 _env _in_scope _val_env arg _arg_occ arg_str @@ -2790,40 +2771,69 @@ valueIsWorkFree :: Value -> Bool valueIsWorkFree LambdaVal = True valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args -samePat :: CallPat -> CallPat -> Bool -samePat (CP { cp_qvars = vs1, cp_args = as1 }) - (CP { cp_qvars = vs2, cp_args = as2 }) - = all2 same as1 as2 +betterPat :: InScopeSet -> CallPat -> CallPat -> Bool +-- pat1 f @a (Just @a (x::a)) +-- is better than +-- pat2 f @Int (Just @Int (x::Int)) +-- That is, we can instantiate pat1 to get pat2 +-- See Note [Pattern duplicate elimination] +betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) + (CP { cp_qvars = vs2, cp_args = as2 }) + = case matchExprs ise vs1 as1 as2 of + Just (_, ms) -> all exprIsTrivial ms + Nothing -> False + where + ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding) + +subsumePats :: InScopeSet -> [CallPat] -> [CallPat] +-- Remove any patterns subsumed by others +-- See Note [Pattern duplicate elimination] +subsumePats is pats = foldr add [] pats where - -- If the args are the same, their strictness marks will be too so we don't compare those. - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 - - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 - - same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $ - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False + add :: CallPat -> [CallPat] -> [CallPat] + add ci [] = [ci] + add ci1 (ci2:cis) | betterPat is ci2 ci1 = ci2:cis + | betterPat is ci1 ci2 = ci1:cis + | otherwise = ci2 : add ci1 cis {- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. +Note [Pattern duplicate elimination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: (a,a) -> blah, and two calls + f @Int (x,y) + f @Bool (p,q) + +The danger is that we'll generate two *essentially identical* specialisations, +both for pairs, but with different types instantiating `a` (see #24229). + +But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises +that argument. So SpecConstr should never need to specialise f's polymorphic +type arguments. Even with only one of these calls we should be able to +generalise to the `CallPat` + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + +Doing so isn't trivial, though. + +For now we content ourselves with a simpler plan: eliminate a call pattern +if another pattern subsumes it; this is done by `subsumePats`. +For example here are two patterns + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)] + +The first can be instantiated to the second, /by instantiating types only/. +This subsumption relationship is checked by `betterPat`. Note that if +we have + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [], cp_args = [@Bool (True,False)] + +the first does *not* subsume the second; the second is more specific. + +In our initial example with `f @Int` and `f @Bool` neither subsumes the other, +so we will get two essentially-identical specialisations. Boo. We rely on our +crude throttling mechanisms to stop this getting out of control -- with +polymorphic recursion we can generate an infinite number of specialisations. +Example is Data.Sequence.adjustTree, I think. -} ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( -- ** Looking up rules - lookupRule, + lookupRule, matchExprs, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -86,6 +86,7 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.List.SetOps( hasNoDups ) +import GHC.Utils.FV( filterFV, fvVarSet ) import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic @@ -720,15 +721,23 @@ matchN :: InScopeEnv -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs +matchN ise _rule_name tmpl_vars tmpl_es target_es rhs + = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + +matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] + -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] +matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - bind_wrapper = rs_binds rule_subst + + ; let bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } + + ; return (bind_wrapper, matched_es) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] @@ -739,7 +748,7 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs , rv_unf = id_unf } lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) - -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + -- Need to return a RuleSubst solely for the benefit of fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) | isId tmpl_var1 @@ -768,7 +777,6 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs unbound tmpl_var = pprPanic "Template variable unbound in rewrite rule" $ vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) - , text "Rule" <+> pprRuleName rule_name , text "Rule bndrs:" <+> ppr tmpl_vars , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] @@ -960,45 +968,78 @@ where 'co' is non-reflexive, we simply fail. You might wonder about but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~ -What if we have (f co) in the template, where the 'co' is a coercion -argument to f? Right now we have nothing in place to ensure that a -coercion /argument/ in the template is a variable. We really should, -perhaps by abstracting over that variable. - -C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. - -For now, though, we simply behave badly, by failing in match_co. -We really should never rely on matching the structure of a coercion -(which is just a proof). - Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the definition +This Note concerns `matchTemplateCast`. Consider the definition f x = e, and SpecConstr on call pattern f ((e1,e2) |> co) -We'll make a RULE +The danger is that We'll make a RULE RULE forall a,b,g. f ((a,b)|> g) = $sf a b g $sf a b g = e[ ((a,b)|> g) / x ] -So here is the invariant: +This requires the rule-matcher to bind the coercion variable `g`. +That is Very Deeply Suspicious: + +* It would be unreasonable to match on a structured coercion in a pattern, + such as RULE forall g. f (x |> Sym g) = ... + because the strucure of a coercion is arbitrary and may change -- it's their + /type/ that matters. + +* We considered insisting that in a template, in a cast (e |> co), the the cast + `co` is always a /variable/ cv. That looks a bit more plausible, but #23209 + (and related tickets) shows that it's very fragile. For example suppose `e` + is a variable `f`, and the simplifier has an unconditional substitution + [f :-> g |> co2] + Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! + +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion +variable. And SpecConstr no longer does so: see Note [SpecConstr and casts] in +SpecConstr. - In the template, in a cast (e |> co), - the cast `co` is always a /variable/. +It is, however, OK for a cast to appear in a template. For example + newtype N a = MkN (a,a) -- Axiom ax:N a :: (a,a) ~R N a + f :: N a -> bah + RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ... -Matching should bind that variable to an actual coercion, so that we -can use it in $sf. So a Cast on the LHS (the template) calls -match_co, which succeeds when the template cast is a variable -- which -it always is. That is why match_co has so few cases. +When matching we can just move these casts to the other side: + match (tmpl |> co) tgt --> match tmpl (tgt |> sym co) +See matchTemplateCast. + +Wrinkles: + +(CT1) We need to be careful about scoping, and to match left-to-right, so that we + know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we + can apply that substitition + +(CT2) Annoyingly, we still want support one case in which the RULE quantifies + over a coercion variable: the dreaded map/coerce RULE. + See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + + Since that can happen, matchTemplateCast laboriously checks whether the + coercion mentions a template coercion variable; and if so does the Very Deeply + Suspicious `match_co` instead. It works fine for map/coerce, where the + coercion is always a variable and will (robustly) remain so. See also * Note [Coercion arguments] * Note [Matching coercion variables] in GHC.Core.Unify. * Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: sm_cast_swizzle is switched off in the template of a RULE + +Note [Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~ +What if we have (f (Coercion co)) in the template, where the 'co' is a coercion +argument to f? Right now we have nothing in place to ensure that a +coercion /argument/ in the template is a variable. We really should, +perhaps by abstracting over that variable. + +C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. + +For now, though, we simply behave badly, by failing in match_co. +We really should never rely on matching the structure of a coercion +(which is just a proof). -} ---------------------- @@ -1060,14 +1101,7 @@ match renv subst e1 (Cast e2 co2) mco -- This is important: see Note [Cancel reflexive casts] match renv subst (Cast e1 co1) e2 mco - = -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 - ; subst1 <- match_co renv subst co1 co2 - -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } + = matchTemplateCast renv subst e1 co1 e2 mco ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco @@ -1290,7 +1324,7 @@ match renv subst (Lam x1 e1) e2 mco in_scope_env = ISE in_scope (rv_unf renv) -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily -- a superset of the free vars of e2; it is only guaranteed a superset of - -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe + -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe -- wants an in-scope set that includes all the free vars of its argument. -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630) , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 @@ -1449,6 +1483,40 @@ Hence -} ------------- +matchTemplateCast + :: RuleMatchEnv -> RuleSubst + -> CoreExpr -> Coercion + -> CoreExpr -> MCoercion + -> Maybe RuleSubst +matchTemplateCast renv subst e1 co1 e2 mco + | isEmptyVarSet $ fvVarSet $ + filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not + tyCoFVsOfCo substed_co -- mention any of the template variables + = -- This is the good path + -- See Note [Casts in the template] + match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + + | otherwise + = -- This is the Deeply Suspicious Path + do { let co2 = case mco of + MRefl -> mkRepReflCo (exprType e2) + MCo co2 -> co2 + ; subst1 <- match_co renv subst co1 co2 + -- If match_co succeeds, then (exprType e1) = (exprType e2) + -- Hence the MRefl in the next line + ; match renv subst1 e1 e2 MRefl } + where + substed_co = substCo current_subst co1 + + current_subst :: Subst + current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) + (rs_tv_subst subst) + emptyCvSubstEnv + -- emptyCvSubstEnv: ugh! + -- If there were any CoVar substitutions they would be in + -- rs_id_subst; but we don't expect there to be any; see + -- Note [Casts in the template] + match_co :: RuleMatchEnv -> RuleSubst -> Coercion ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -818,35 +818,40 @@ The naive core produced for this is This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding +too. Achieving all this is surprisingly tricky: - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... +(MC1) We must compulsorily unfold MkAge to a cast. + See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: +(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) - - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: + Getting better. But this isn't exactly what gets produced. This is because + Coercible essentially has ~R# as a superclass, and superclasses get eagerly + extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + + Unfortunately, this still abstracts over a Coercible dictionary. We really + want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, + which transforms the above to + Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + + See Note [Desugaring coerce as cast] in GHC.HsToCore + +(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three + separate actions: 1. Inline certain non-recursive bindings. The choice whether to inline is made in simple_bind_pair. Note the rather specific check for MkCoercible in there. @@ -858,6 +863,10 @@ separate actions: just packed and inline them. This is also done in simple_opt_expr's `go` function. +(MC4) The map/coerce rule is the only compelling reason for having a RULE that + quantifies over a coercion variable, something that is otherwise Very Deeply + Suspicous. See Note [Casts in the template] in GHC.Core.Rules. Ugh! + This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across. ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Core.Subst ( substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, + emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendIdSubstWithClone, extendSubst, extendSubstList, extendSubstWithVar, ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Core.TyCo.Subst Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, - mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst, getTvSubstEnv, getIdSubstEnv, getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, isInScope, elemSubst, notElemSubst, zapSubst, @@ -271,8 +271,8 @@ isEmptyTCvSubst :: Subst -> Bool isEmptyTCvSubst (Subst _ _ tv_env cv_env) = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs +mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst +mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -198,7 +198,7 @@ module GHC.Core.Type ( -- ** Manipulating type substitutions emptyTvSubstEnv, emptySubst, mkEmptySubst, - mkSubst, zipTvSubst, mkTvSubstPrs, + mkTCvSubst, zipTvSubst, mkTvSubstPrs, zipTCvSubst, notElemSubst, getTvSubstEnv, ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -1481,7 +1481,7 @@ getSubst :: UMEnv -> UM Subst getSubst env = do { tv_env <- getTvSubstEnv ; cv_env <- getCvSubstEnv ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } + ; return (mkTCvSubst in_scope tv_env cv_env) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -608,7 +608,7 @@ createBuildPlan mod_graph maybe_top_mod = -- Now perform another toposort but just with these nodes and relevant hs-boot files. -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. mresolved_cycle = collapseSCC (topSortWithBoot nodes) - in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] + in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload) @@ -639,12 +639,12 @@ createBuildPlan mod_graph maybe_top_mod = get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing -- Any cycles should be resolved now - collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] + collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle - collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2] + collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes -- Cyclic - collapseSCC _ = Nothing + collapseSCC nodes = Left (flattenSCCs nodes) toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile toNodeWithBoot mn = ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -166,7 +166,7 @@ module GHC.Tc.Utils.TcType ( extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, ===================================== libraries/base/src/GHC/Unicode.hs ===================================== @@ -208,6 +208,17 @@ isControl c = case generalCategory c of -- | Selects printable Unicode characters -- (letters, numbers, marks, punctuation, symbols and spaces). +-- +-- This function returns 'False' if its argument has one of the +-- following 'GeneralCategory's, or 'True' otherwise: +-- +-- * 'LineSeparator' +-- * 'ParagraphSeparator' +-- * 'Control' +-- * 'Format' +-- * 'Surrogate' +-- * 'PrivateUse' +-- * 'NotAssigned' isPrint :: Char -> Bool isPrint c = case generalCategory c of LineSeparator -> False @@ -302,6 +313,20 @@ isLowerCase = DCP.isLowercase -- | Selects alphabetic Unicode characters (lower-case, upper-case and -- title-case letters, plus letters of caseless scripts and modifiers letters). -- This function is equivalent to 'Data.Char.isLetter'. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'UppercaseLetter' +-- * 'LowercaseLetter' +-- * 'TitlecaseLetter' +-- * 'ModifierLetter' +-- * 'OtherLetter' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Letter\". isAlpha :: Char -> Bool isAlpha c = case generalCategory c of UppercaseLetter -> True @@ -316,7 +341,20 @@ isAlpha c = case generalCategory c of -- Note that numeric digits outside the ASCII range, as well as numeric -- characters which aren't digits, are selected by this function but not by -- 'isDigit'. Such characters may be part of identifiers but are not used by --- the printer and reader to represent numbers. +-- the printer and reader to represent numbers, e.g., Roman numerals like @'V'@, +-- full-width digits like @'１'@ (aka @'\65297'@). +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'UppercaseLetter' +-- * 'LowercaseLetter' +-- * 'TitlecaseLetter' +-- * 'ModifierLetter' +-- * 'OtherLetter' +-- * 'DecimalNumber' +-- * 'LetterNumber' +-- * 'OtherNumber' isAlphaNum :: Char -> Bool isAlphaNum c = case generalCategory c of UppercaseLetter -> True ===================================== testsuite/tests/driver/T24196/T24196.stderr ===================================== @@ -0,0 +1,4 @@ +Module graph contains a cycle: + module ‘T24196A’ (./T24196A.hs-boot) + imports module ‘T24196B’ (T24196B.hs) + which imports module ‘T24196A’ (./T24196A.hs-boot) ===================================== testsuite/tests/driver/T24196/T24196A.hs ===================================== @@ -0,0 +1 @@ +module T24196A where ===================================== testsuite/tests/driver/T24196/T24196A.hs-boot ===================================== @@ -0,0 +1,3 @@ +module T24196A where + +import T24196B ===================================== testsuite/tests/driver/T24196/T24196B.hs ===================================== @@ -0,0 +1,3 @@ +module T24196B where + +import {-# SOURCE #-} T24196A ===================================== testsuite/tests/driver/T24196/all.T ===================================== @@ -0,0 +1 @@ +test('T24196', extra_files(['T24196A.hs','T24196A.hs-boot','T24196B.hs']), multimod_compile_fail, ['T24196B','']) ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -372,7 +372,10 @@ test('MultiLayerModulesTH_OneShot', pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'), extra_files(['genMultiLayerModulesTH']), unless(have_dynamic(),skip), - compile_timeout_multiplier(5) + compile_timeout_multiplier(5), + # We skip the test on darwin due to recent regression due to toolchain + # upgrade (tracked in #24177) + when(opsys('darwin'), skip) ], compile_fail, # see Note [Increased initial stack size for MultiLayerModules] ===================================== testsuite/tests/simplCore/should_compile/T23209.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} + +-- This gave a Lint crash + +module T23209 where + +import T23209_Aux + +f a = let w = if a then Allocator (ArrayWriter s) + else Allocator (ArrayWriter e) + in case combine w w of ===================================== testsuite/tests/simplCore/should_compile/T23209_Aux.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -O #-} +module T23209_Aux where + +newtype I = MkI { uI :: () -> () } +newtype ArrayWriter = ArrayWriter (() -> I) +data Allocator = Allocator !ArrayWriter + +combine :: Allocator -> Allocator -> (# () -> () #) +combine (Allocator (ArrayWriter w1)) (Allocator (ArrayWriter w2)) = + (# \s -> id' (uI (w1 ()) (uI (w2 ()) s)) #) + +e, s :: () -> I +e x = MkI id +s x = MkI id +{-# NOINLINE s #-} + +id' :: () -> () +id' x = x ===================================== testsuite/tests/simplCore/should_compile/T24229a.hs ===================================== @@ -0,0 +1,14 @@ +module T24229a where + +newtype N a = MkN a + +foo :: Int -> N (a,a) -> Maybe (a,a) +foo 0 (MkN p) = Just p +foo n (MkN (x,y)) = foo (n-1) (MkN (y,x)) + +-- We should generate ONE specialisation for $wfoo, +-- and it should fire TWICE, regardless of the order +-- of the following two definitions. + +wombat1 = foo 20 (MkN ("yes", "no")) +wombat2 xs ys = foo 3 (MkN (xs, ys)) ===================================== testsuite/tests/simplCore/should_compile/T24229a.stderr ===================================== @@ -0,0 +1,38 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 79, types: 106, coercions: 8, joins: 0/0} + +Rec { +foo_$s$wfoo + = \ @a sc sc1 sc2 -> + case sc2 of ds { + __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#); + 0# -> (# (sc, sc1) #) + } +end Rec } + +foo + = \ @a ds ds1 -> + case ds of { I# ww -> + case ww of ds2 { + __DEFAULT -> case ds1 `cast` :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } }; + 0# -> Just (ds1 `cast` :: ...) + } + } + +wombat7 = "yes"# + +wombat6 = unpackCString# wombat7 + +wombat5 = "no"# + +wombat4 = unpackCString# wombat5 + +wombat1 = case foo_$s$wfoo wombat6 wombat4 20# of { (# ww #) -> Just ww } + +wombat8 = I# 3# + +wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww } + + + ===================================== testsuite/tests/simplCore/should_compile/T24229b.hs ===================================== @@ -0,0 +1,13 @@ +module T24229b where + +newtype N a = MkN a + +foo :: Int -> N (a,a) -> Maybe (a,a) +foo 0 (MkN p) = Just p +foo n (MkN (x,y)) = foo (n-1) (MkN (y,x)) + +-- We should generate ONE specialisation for $wfoo, +-- and it should fire TWICE, regardless of the order +-- of the following two definitions. + +wombat2 xs ys = foo 3 (MkN (xs, ys)) ===================================== testsuite/tests/simplCore/should_compile/T24229b.stderr ===================================== @@ -0,0 +1,28 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 60, types: 83, coercions: 8, joins: 0/0} + +Rec { +foo_$s$wfoo + = \ @a sc sc1 sc2 -> + case sc2 of ds { + __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#); + 0# -> (# (sc, sc1) #) + } +end Rec } + +foo + = \ @a ds ds1 -> + case ds of { I# ww -> + case ww of ds2 { + __DEFAULT -> case ds1 `cast` :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } }; + 0# -> Just (ds1 `cast` :: ...) + } + } + +wombat1 = I# 3# + +wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -508,4 +508,6 @@ test('T24014', normal, compile, ['-dcore-lint']) test('T24029', normal, compile, ['']) test('T21348', normal, compile, ['-O']) test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules']) - +test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O']) +test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999']) +test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f049697f637ac27dc64bcaf6d0df1399dfae49a...9af3df67346ad5e908a6104ef944b4bdaba4882d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f049697f637ac27dc64bcaf6d0df1399dfae49a...9af3df67346ad5e908a6104ef944b4bdaba4882d 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 Dec 7 15:02:07 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Thu, 07 Dec 2023 10:02:07 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: HsOverLabel: move annotation info to xrec-stuff Message-ID: <6571de6f464c_1531771844d8c0129840@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 996775cb by Alan Zimmerman at 2023-12-07T15:00:50+00:00 EPA: HsOverLabel: move annotation info to xrec-stuff - - - - - 5 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Expr.hs - compiler/GHC/ThToHs.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -219,8 +219,8 @@ type instance XRecSel GhcTc = NoExtField -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XOverLabel GhcPs = EpAnnCO -type instance XOverLabel GhcRn = EpAnnCO +type instance XOverLabel GhcPs = NoExtField +type instance XOverLabel GhcRn = NoExtField type instance XOverLabel GhcTc = DataConCantHappen -- --------------------------------------------------------------------- ===================================== compiler/GHC/Parser.y ===================================== @@ -2958,7 +2958,9 @@ aexp2 :: { ECP } | qcon { ECP $ mkHsVarPV $! $1 } -- See Note [%shift: aexp2 -> ipvar] | ipvar %shift {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) } - | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) } + -- | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) } + | overloaded_label {% fmap ecpFromExp + (ams1 $1 (HsOverLabel NoExtField (fst $! unLoc $1) (snd $! unLoc $1))) } | literal { ECP $ pvA (mkHsLitPV $! $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -XOverloadedStrings is on. @@ -4354,6 +4356,11 @@ acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acs a ; return (ecpFromExp $ expr) } +ams1 :: MonadP m => Located a -> b -> m (LocatedA b) +ams1 (L l a) b = do + cs <- getCommentsFor (locA l) + return (L (EpAnn (spanAsAnchor l) noAnn cs) b) + amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) amsA (L l a) bs = do cs <- getCommentsFor (locA l) ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -292,7 +292,7 @@ rnExpr (HsUnboundVar _ v) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] rnExpr (HsOverLabel _ src v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; return ( mkExpandedExpr (HsOverLabel noAnn src v) $ + ; return ( mkExpandedExpr (HsOverLabel noExtField src v) $ HsAppType noExtField (genLHsVar from_label) hs_ty_arg , fvs ) } where ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1153,7 +1153,7 @@ cvtl e = wrapLA (cvt e) -- constructor names - see #14627. { s' <- vcName s ; wrapParLA (HsVar noExtField) s' } - cvt (LabelE s) = return $ HsOverLabel noComments NoSourceText (fsLit s) + cvt (LabelE s) = return $ HsOverLabel noExtField NoSourceText (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp ; return $ HsGetField noComments e' ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2860,7 +2860,7 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsVar{}) = NoEntryVal getAnnotationEntry (HsUnboundVar an _) = fromAnn an getAnnotationEntry (HsRecSel{}) = NoEntryVal - getAnnotationEntry (HsOverLabel an _ _) = fromAnn an + getAnnotationEntry (HsOverLabel{}) = NoEntryVal getAnnotationEntry (HsIPVar an _) = fromAnn an getAnnotationEntry (HsOverLit an _) = fromAnn an getAnnotationEntry (HsLit an _) = fromAnn an @@ -2897,8 +2897,8 @@ instance ExactPrint (HsExpr GhcPs) where setAnnotationAnchor a@(HsVar{}) _ _ _s = a setAnnotationAnchor (HsUnboundVar an a) anc ts cs = (HsUnboundVar (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(HsRecSel{}) _ _ _s = a - setAnnotationAnchor (HsOverLabel an s a) anc ts cs = (HsOverLabel (setAnchorEpa an anc ts cs) s a) + setAnnotationAnchor a@(HsRecSel{}) _ _ _s = a + setAnnotationAnchor a@(HsOverLabel{}) _ _ _s = a setAnnotationAnchor (HsIPVar an a) anc ts cs = (HsIPVar (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (HsOverLit an a) anc ts cs = (HsOverLit (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (HsLit an a) anc ts cs = (HsLit (setAnchorEpa an anc ts cs) a) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/996775cb89059ead74636f15c67acd72d7b05b7f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/996775cb89059ead74636f15c67acd72d7b05b7f 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 Dec 7 15:49:51 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Thu, 07 Dec 2023 10:49:51 -0500 Subject: [Git][ghc/ghc][wip/spj-unf-size] 2 commits: Better eqString/eqList stuff Message-ID: <6571e99fa16fc_15317719311d9813237a@gitlab.mail> Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC Commits: ba3e72ea by Simon Peyton Jones at 2023-12-07T15:45:12+00:00 Better eqString/eqList stuff - - - - - 97e35465 by Simon Peyton Jones at 2023-12-07T15:49:08+00:00 Adjust * Reduce caseElimDiscount to 10 Example: f_nand in spectral/hartel/event is quite big but was still getting inlined; that make f_simulate too big for SpecConstr * Increase jumpSize. Not so much cheaper than tail calls. I'm trying making them the same size. - - - - - 4 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Core/Unfold.hs - libraries/base/src/GHC/Base.hs - libraries/ghc-prim/GHC/Classes.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -1018,7 +1018,7 @@ unpackCStringName, unpackCStringFoldrName, unpackCStringAppendName, unpackCStringAppendUtf8Name, eqStringName, cstringLengthName :: Name cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey -eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey +eqStringName = varQual gHC_CLASSES (fsLit "eqString") eqStringIdKey unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -207,7 +207,7 @@ defaultUnfoldingOpts = UnfoldingOpts -- into the interface file.) , unfoldingUseThreshold = 75 - -- Adjusted 90 -> 80 when adding discounts for free variables which + -- Adjusted 90 -> 75 when adding discounts for free variables which -- generally make things more likely to inline. Reducing the threshold -- eliminates some undesirable compile-time regressions (e.g. T10412a) -- @@ -823,7 +823,9 @@ vanillaCallSize n_val_args voids = 10 * (1 + n_val_args - voids) -- | The size of a jump to a join point jumpSize :: Int -> Int -> Size -jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) +jumpSize n_val_args voids = 10 * (n_val_args - voids) + -- Not so much smaller than an ordinary call; + -- Trying the effect of not charging for the function head itself -- A jump is 20% the size of a function call. Making jumps free reopens -- bug #6048, but making them any more expensive loses a 21% improvement in -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a @@ -913,7 +915,7 @@ caseSize scrut_id alts caseElimDiscount :: Discount -- Bonus for eliminating a case -caseElimDiscount = 15 +caseElimDiscount = 10 {- Note [Bale out on very wide case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -1666,17 +1666,6 @@ unsafeChr (I# i#) = C# (chr# i#) ord :: Char -> Int ord (C# c#) = I# (ord# c#) --- | This 'String' equality predicate is used when desugaring --- pattern-matches against strings. -eqString :: String -> String -> Bool -eqString [] [] = True -eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 -eqString _ _ = False - -{-# RULES "eqString" (==) = eqString #-} --- eqString also has a BuiltInRule in GHC.Core.Opt.ConstantFold: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 - ---------------------------------------------- -- 'Int' related definitions ===================================== libraries/ghc-prim/GHC/Classes.hs ===================================== @@ -47,7 +47,8 @@ module GHC.Classes( eqInt, neInt, eqWord, neWord, eqChar, neChar, - eqFloat, eqDouble, + eqFloat, eqDouble, eqString, + -- ** Monomorphic comparison operators gtInt, geInt, leInt, ltInt, compareInt, compareInt#, gtWord, geWord, leWord, ltWord, compareWord, compareWord#, @@ -146,10 +147,8 @@ class Eq a where {-# INLINE (/=) #-} {-# INLINE (==) #-} - -- Write these with no arg, so that they inline even as the argument of - -- the DFun. Then the RULES for eqList can fire. - (/=) = \x y -> not (x == y) - (==) = \x y -> not (x /= y) + (/=) x y = not (x == y) + (==) x y = not (x /= y) {-# MINIMAL (==) | (/=) #-} deriving instance Eq () @@ -187,6 +186,7 @@ deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o) => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +---------------------------------------------- instance (Eq a) => Eq [a] where {-# SPECIALISE instance Eq [[Char]] #-} {-# SPECIALISE instance Eq [Char] #-} @@ -196,18 +196,47 @@ instance (Eq a) => Eq [a] where -- These rules avoid the recursive function when -- one of the arguments is the empty list. We want -- good code for xs == [] or xs /= [] +-- The sequence is this: +-- (/=) @ty ($dEqList d) xs [] +-- -->{ClassOp rule} $dm/= @ty d xs [] +-- -->{inline $dm/=} not (eqList d xs []) +-- and now the eqList1 rule can fire {-# RULES -"eqList1" forall xs. eqList xs [] = case xs of { [] -> True; _ -> False } -"eqList2" forall ys. eqList [] ys = case ys of { [] -> True; _ -> False } +"eqList1" forall xs. eqList xs [] = null xs +"eqList2" forall xs. eqList [] xs = null xs #-} eqList :: Eq a => [a] -> [a] -> Bool -{-# NOINLINE [1] eqList #-} -- Give the RULES eqList1/eqList2 a chance to fire -- eqList should auto-specialise for the same types as specialise instance Eq above eqList [] [] = True eqList (x:xs) (y:ys) = x == y && eqList xs ys -eqList _xs _ys = False - +eqList _xs _ys = False + +-- We give a manual specialisation for eqList @Char = eqString, so that we can give +-- eqString a BuiltInRule in GHC.Core.Opt.ConstantFold: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 +-- Tiresomely, we have to duplicate rules eqList1 and eqList2 +-- (The manual specialistion RULE "eqString" should mean that we don't +-- auto-specialise eqList @String.) +{-# RULES +"eqString" eqList = eqString +"eqString1" forall xs. eqString xs [] = null xs +"eqString2" forall xs. eqString [] xs = null xs + #-} + +null :: [a] -> Bool +-- Defined in base:Data.List but we need it here +null [] = True +null (_:_) = False + +-- | This 'String' equality predicate is used when desugaring +-- pattern-matches against strings. +eqString :: [Char] -> [Char] -> Bool +eqString [] [] = True +eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 +eqString _ _ = False + +---------------------------------------------- deriving instance Eq Module instance Eq TrName where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2543041d905315f7ab7adb207640ca827d25b0ff...97e35465d3e6897c96dea6d256eaf46e678b5f8f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2543041d905315f7ab7adb207640ca827d25b0ff...97e35465d3e6897c96dea6d256eaf46e678b5f8f 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 Dec 7 16:22:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 07 Dec 2023 11:22:39 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: driver: Ensure we actually clear the interactive context before reloading Message-ID: <6571f14f4519e_1531771a352c701424cd@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 3ced6cb9 by Zubin Duggal at 2023-12-07T11:22:27-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 - - - - - 373dff6b by Zubin Duggal at 2023-12-07T11:22:27-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 - - - - - cdc1ef62 by Zubin Duggal at 2023-12-07T11:22:27-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 - - - - - 01734d67 by Zubin Duggal at 2023-12-07T11:22:27-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 - - - - - 9d9b9287 by Zubin Duggal at 2023-12-07T11:22:27-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - c1af0cb0 by Simon Peyton Jones at 2023-12-07T11:22:28-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - 65fcc7b9 by Simon Peyton Jones at 2023-12-07T11:22:28-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] - - - - - e7d9caaf by Zubin Duggal at 2023-12-07T11:22:28-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 - - - - - fca23e8f by Zubin Duggal at 2023-12-07T11:22:29-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 3fe66e5d by Wendao Lee at 2023-12-07T11:22:32-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> - - - - - 30 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T - + testsuite/tests/simplCore/should_compile/T23209.hs - + testsuite/tests/simplCore/should_compile/T23209_Aux.hs - + testsuite/tests/simplCore/should_compile/T24229a.hs - + testsuite/tests/simplCore/should_compile/T24229a.stderr - + testsuite/tests/simplCore/should_compile/T24229b.hs - + testsuite/tests/simplCore/should_compile/T24229b.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9af3df67346ad5e908a6104ef944b4bdaba4882d...3fe66e5dc8000ab388619bbec77a50aa34215d6e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9af3df67346ad5e908a6104ef944b4bdaba4882d...3fe66e5dc8000ab388619bbec77a50aa34215d6e 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 Dec 7 17:59:08 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Thu, 07 Dec 2023 12:59:08 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/spj-comments Message-ID: <657207ec68698_1531771c66893019213e@gitlab.mail> Simon Peyton Jones pushed new branch wip/spj-comments at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/spj-comments 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 Dec 7 19:43:43 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 07 Dec 2023 14:43:43 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 13 commits: testsuite: add test for #23944 Message-ID: <6572206f43347_1531771f56c204218111@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 56c8fb5b by Zubin Duggal at 2023-12-07T14:42:51-05:00 testsuite: add test for #23944 - - - - - 44143814 by Zubin Duggal at 2023-12-07T14:42:51-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. - - - - - 60f995e8 by Zubin Duggal at 2023-12-07T14:42:52-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 - - - - - 43c172a9 by Zubin Duggal at 2023-12-07T14:42:52-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 - - - - - 3f6a42c9 by Zubin Duggal at 2023-12-07T14:42:52-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 - - - - - 259b6fab by Zubin Duggal at 2023-12-07T14:42:52-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 - - - - - 95656d90 by Zubin Duggal at 2023-12-07T14:42:52-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 56e09e67 by Simon Peyton Jones at 2023-12-07T14:42:53-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - bc6d3ed5 by Simon Peyton Jones at 2023-12-07T14:42:53-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] - - - - - efb3a3aa by Zubin Duggal at 2023-12-07T14:42:53-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 - - - - - 549f02bb by Zubin Duggal at 2023-12-07T14:42:54-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 280f5b6f by Wendao Lee at 2023-12-07T14:42:57-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> - - - - - 412e120c by Malik Ammar Faisal at 2023-12-07T14:43:03-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/driver/all.T - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3fe66e5dc8000ab388619bbec77a50aa34215d6e...412e120ce7d5528325125dd4250f0c1066b6da88 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3fe66e5dc8000ab388619bbec77a50aa34215d6e...412e120ce7d5528325125dd4250f0c1066b6da88 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 Dec 7 20:32:10 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Thu, 07 Dec 2023 15:32:10 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24245 Message-ID: <65722bcae7608_153177207827542255ef@gitlab.mail> Oleg Grenrus pushed new branch wip/T24245 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24245 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 Dec 7 20:45:26 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Thu, 07 Dec 2023 15:45:26 -0500 Subject: [Git][ghc/ghc][wip/T24190] Allow untyped brackets in typed splices and vice versa. Message-ID: <65722ee68f1f2_15317720cc8470233891@gitlab.mail> Oleg Grenrus pushed to branch wip/T24190 at Glasgow Haskell Compiler / GHC Commits: 67f373cc by Oleg Grenrus at 2023-12-07T22:45:15+02: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. - - - - - 6 changed files: - compiler/GHC/Rename/Splice.hs - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,31 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untpyed/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +118,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +147,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -598,3 +598,4 @@ test('T23968', normal, compile_and_run, ['']) test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67f373ccde2cfb7e16e0fe34d47704690263762a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/67f373ccde2cfb7e16e0fe34d47704690263762a 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 Dec 7 21:03:18 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Thu, 07 Dec 2023 16:03:18 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Moving non-token annotations out of HsIPVar, HsOverLit, HsLit Message-ID: <65723316a6248_1531772123663c2358f3@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 6058c011 by Alan Zimmerman at 2023-12-07T21:01:15+00:00 EPA: Moving non-token annotations out of HsIPVar, HsOverLit, HsLit - - - - - 25 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/ThToHs.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -128,7 +128,7 @@ data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr")) +noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr")) noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after @@ -227,7 +227,7 @@ type instance XOverLabel GhcTc = DataConCantHappen type instance XVar (GhcPass _) = NoExtField -type instance XUnboundVar GhcPs = EpAnn (Maybe EpAnnUnboundVar) +type instance XUnboundVar GhcPs = Maybe EpAnnUnboundVar type instance XUnboundVar GhcRn = NoExtField type instance XUnboundVar GhcTc = HoleExprRef -- We really don't need the whole HoleExprRef; just the IORef EvTerm @@ -235,11 +235,11 @@ type instance XUnboundVar GhcTc = HoleExprRef -- Much, much easier just to define HoleExprRef with a Data instance and -- store the whole structure. -type instance XIPVar GhcPs = EpAnnCO -type instance XIPVar GhcRn = EpAnnCO +type instance XIPVar GhcPs = NoExtField +type instance XIPVar GhcRn = NoExtField type instance XIPVar GhcTc = DataConCantHappen -type instance XOverLitE (GhcPass _) = EpAnnCO -type instance XLitE (GhcPass _) = EpAnnCO +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField type instance XLam (GhcPass _) = EpAnn [AddEpAnn] type instance XApp (GhcPass _) = EpAnnCO ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -513,10 +513,10 @@ nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLocA (HsLit noComments n) +nlHsLit n = noLocA (HsLit noExtField n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n))) +nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) nlVarPat :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) ===================================== compiler/GHC/Parser.y ===================================== @@ -2957,11 +2957,11 @@ aexp2 :: { ECP } : qvar { ECP $ mkHsVarPV $! $1 } | qcon { ECP $ mkHsVarPV $! $1 } -- See Note [%shift: aexp2 -> ipvar] - | ipvar %shift {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) } - -- | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) } + | ipvar %shift {% fmap ecpFromExp + (ams1 $1 (HsIPVar NoExtField $! unLoc $1)) } | overloaded_label {% fmap ecpFromExp (ams1 $1 (HsOverLabel NoExtField (fst $! unLoc $1) (snd $! unLoc $1))) } - | literal { ECP $ pvA (mkHsLitPV $! $1) } + | literal { ECP $ mkHsLitPV $! $1 } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -XOverloadedStrings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) @@ -3760,16 +3760,15 @@ varop :: { LocatedN RdrName } qop :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections : qvarop { mkHsVarOpPV $1 } | qconop { mkHsConOpPV $1 } - | hole_op { pvN $1 } + | hole_op { mkHsInfixHolePV $1 } qopm :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections : qvaropm { mkHsVarOpPV $1 } | qconop { mkHsConOpPV $1 } - | hole_op { pvN $1 } + | hole_op { mkHsInfixHolePV $1 } -hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections -hole_op : '`' '_' '`' { mkHsInfixHolePV (comb2 $1 $>) - (\cs -> EpAnn (glEE $1 $>) (Just $ EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) } +hole_op :: { LocatedN (HsExpr GhcPs) } -- used in sections +hole_op : '`' '_' '`' { sLLa $1 $> (hsHoleExpr (Just $ EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2))) } qvarop :: { LocatedN RdrName } : qvarsym { $1 } @@ -4416,9 +4415,9 @@ pvA :: (MonadP m, NoAnn t) => m (Located a) -> m (LocatedAn t a) pvA a = do { av <- a ; return (reLoc av) } -pvN :: MonadP m => m (Located a) -> m (LocatedN a) +pvN :: MonadP m => m (LocatedN a) -> m (LocatedN a) pvN a = do { (L l av) <- a - ; return (L (noAnnSrcSpan l) av) } + ; return (L l av) } pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) pvL a = do { av <- a ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -1088,8 +1088,11 @@ instance (HasLoc a) => (HasLoc (Maybe a)) where getHasLoc Nothing = noSrcSpan instance HasLoc (EpAnn a) where - getHasLoc (EpAnn (EpaSpan l) _ _) = l - getHasLoc (EpAnn (EpaDelta _ _) _ _) = noSrcSpan + getHasLoc (EpAnn l _ _) = getHasLoc l + +instance HasLoc EpaLocation where + getHasLoc (EpaSpan l) = l + getHasLoc (EpaDelta _ _) = noSrcSpan getHasLocList :: HasLoc a => [a] -> SrcSpan getHasLocList [] = noSrcSpan ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -109,6 +109,7 @@ module GHC.Parser.PostProcess ( ecpFromExp, ecpFromCmd, PatBuilder, + hsHoleExpr, -- Type/datacon ambiguity resolution DisambTD(..), @@ -1519,19 +1520,17 @@ type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (Locate class DisambInfixOp b where mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) - mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn (Maybe EpAnnUnboundVar)) -> PV (Located b) + mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN b) instance DisambInfixOp (HsExpr GhcPs) where mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l ann = do - cs <- getCommentsFor l - return $ L l (hsHoleExpr (ann cs)) + mkHsInfixHolePV h = return h instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole + mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole type AnnoBody b = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnn NoEpAnns @@ -1608,7 +1607,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate a variable "f" or a data constructor "MkF". mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) -- | Disambiguate a monomorphic literal - mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) + mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b) -- | Disambiguate an overloaded literal mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) -- | Disambiguate a wildcard @@ -1828,13 +1827,15 @@ instance DisambECP (HsExpr GhcPs) where mkHsParPV l lpar e rpar = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) - mkHsVarPV v@(L l _) = return $ L (l2l l) (HsVar noExtField v) + mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do + cs <- getCommentsFor (getHasLoc l) + return $ L (EpAnn anc noAnn cs) (HsVar noExtField v) mkHsLitPV (L l a) = do cs <- getCommentsFor l - return $ L l (HsLit (comment (realSrcSpan l) cs) a) - mkHsOverLitPV (L l a) = do + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a) + mkHsOverLitPV (L (EpAnn l an csIn) a) = do cs <- getCommentsFor (locA l) - return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a) + return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) mkHsTySigPV l a sig anns = do cs <- getCommentsFor (locA l) @@ -1874,7 +1875,7 @@ instance DisambECP (HsExpr GhcPs) where (PsErrUnallowedPragma prag) rejectPragmaPV _ = return () -hsHoleExpr :: EpAnn (Maybe EpAnnUnboundVar) -> HsExpr GhcPs +hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_"))) instance DisambECP (PatBuilder GhcPs) where @@ -1906,7 +1907,8 @@ instance DisambECP (PatBuilder GhcPs) where mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedLitPat lit - return $ L l (PatBuilderPat (LitPat noExtField a)) + cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig anns = do ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -397,7 +397,7 @@ mkQuasiQuoteExpr flavour quoter (L q_span' quote) where q_span = noAnnSrcSpan (locA q_span') quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter) - quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -743,7 +743,7 @@ genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) (mkEmptyWildCardBndrs (wrapGenSpan ty)) genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) -genLHsLit = wrapGenSpan . HsLit noAnn +genLHsLit = wrapGenSpan . HsLit noExtField genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn) genHsIntegralLit = genLHsLit . HsInt noExtField ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -515,7 +515,7 @@ gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon where tag = get_tag data_con tag_lit - = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag))) + = noLocA (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -212,7 +212,7 @@ tcExpr e@(HsOverLit _ lit) res_ty = do { mb_res <- tcShortCutLit lit res_ty -- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type ; case mb_res of - Just lit' -> return (HsOverLit noAnn lit') + Just lit' -> return (HsOverLit noExtField lit') Nothing -> tcApp e res_ty } -- Typecheck an occurrence of an unbound Id ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -1077,21 +1077,21 @@ tcInferOverLit lit@(OverLit { ol_val = val ; let thing = NameThing from_name mb_thing = Just thing - herald = ExpectedFunTyArg thing (HsLit noAnn hs_lit) + herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing (1, []) from_ty ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ - HsLit noAnn hs_lit + HsLit noExtField hs_lit from_expr = mkHsWrap (wrap2 <.> wrap1) $ HsVar noExtField (L loc from_id) witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable , ol_witness = witness , ol_type = res_ty } } - ; return (HsOverLit noAnn lit', res_ty) } + ; return (HsOverLit noExtField lit', res_ty) } {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -971,7 +971,7 @@ stubNestedSplice :: HsExpr GhcTc -- do a debug-print. The warning is because this should never happen -- /except/ when doing debug prints. stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $ - HsLit noComments (mkHsString "stubNestedSplice") + HsLit noExtField (mkHsString "stubNestedSplice") {- ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1875,7 +1875,7 @@ tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID error_msg dflags = L inst_loc' - (HsLit noComments (HsStringPrim NoSourceText + (HsLit noExtField (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -1042,12 +1042,12 @@ tcPatToExpr args pat = go pat ; return $ ExplicitSum noExtField alt arity (noLocA expr) } - go1 (LitPat _ lit) = return $ HsLit noComments lit + go1 (LitPat _ lit) = return $ HsLit noExtField lit go1 (NPat _ (L _ n) mb_neg _) | Just (SyntaxExprRn neg) <- mb_neg = return $ unLoc $ foldl' nlHsApp (noLocA neg) - [noLocA (HsOverLit noAnn n)] - | otherwise = return $ HsOverLit noAnn n + [noLocA (HsOverLit noExtField n)] + | otherwise = return $ HsOverLit noExtField n go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -2364,11 +2364,11 @@ shortCutLit platform val res_ty where go_integral int@(IL src neg i) | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noAnn (HsInt noExtField int)) + = Just (HsLit noExtField (HsInt noExtField int)) | isWordTy res_ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy res_ty - = Just (HsLit noAnn (HsInteger src i res_ty)) + = Just (HsLit noExtField (HsInteger src i res_ty)) | otherwise = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important @@ -2389,7 +2389,7 @@ shortCutLit platform val res_ty -- is less than 100, which ensures desugaring isn't slow. go_string src s - | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1028,9 +1028,9 @@ cvtl e = wrapLA (cvt e) cvt (VarE s) = do { s' <- vName s; wrapParLA (HsVar noExtField) s' } cvt (ConE s) = do { s' <- cName s; wrapParLA (HsVar noExtField) s' } cvt (LitE l) - | overloadedLit l = go cvtOverLit (HsOverLit noComments) + | overloadedLit l = go cvtOverLit (HsOverLit noExtField) (hsOverLitNeedsParens appPrec) - | otherwise = go cvtLit (HsLit noComments) + | otherwise = go cvtLit (HsLit noExtField) (hsLitNeedsParens appPrec) where go :: (Lit -> CvtM (l GhcPs)) @@ -1090,7 +1090,7 @@ cvtl e = wrapLA (cvt e) ; return $ ArithSeq noAnn Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) - ; return (HsLit noComments l') } + ; return (HsLit noExtField l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs ; return $ ExplicitList noAnn xs' @@ -1154,7 +1154,7 @@ cvtl e = wrapLA (cvt e) { s' <- vcName s ; wrapParLA (HsVar noExtField) s' } cvt (LabelE s) = return $ HsOverLabel noExtField NoSourceText (fsLit s) - cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } + cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) } ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -124,11 +124,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { T22919.hs:2:7-9 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsChar (SourceText 's') ('s'))))))] ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -136,11 +136,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { ZeroWidthSemi.hs:6:5 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2408,11 +2408,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpParsedAst.hs:25:17-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsString (SourceText "hello") {FastString: "hello"})))))))] ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -145,11 +145,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:9:7 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral @@ -312,11 +308,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:16:3 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral @@ -450,11 +442,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:19:17-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsString (SourceText "hello") {FastString: "hello"})))))))] ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -122,11 +122,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpRenamedAst.hs:35:17-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsString (SourceText "hello") {FastString: "hello"})))))))] ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -2062,11 +2062,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { DumpSemis.hs:34:21 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral @@ -2166,11 +2162,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { DumpSemis.hs:34:26 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral @@ -2417,11 +2409,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpSemis.hs:39:11-13 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsChar (SourceText 'a') ('a'))))))] @@ -2496,11 +2484,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpSemis.hs:40:11-13 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsChar (SourceText 'b') ('b'))))))] @@ -2577,11 +2561,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpSemis.hs:41:11-13 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsChar (SourceText 'c') ('c'))))))] @@ -2660,11 +2640,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpSemis.hs:42:11-13 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsChar (SourceText 'd') ('d'))))))] ===================================== testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr ===================================== @@ -110,11 +110,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (1374752024144278257) (NoSourceText)})))) (L (EpAnn @@ -124,11 +120,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (13654949607623281177) (NoSourceText)})))) (L (EpAnn @@ -189,11 +181,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "T"))))))))) @@ -205,11 +193,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsInt{64}Prim (1) (NoSourceText)})))) (L (EpAnn @@ -336,11 +320,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (10715337633704422415) (NoSourceText)})))) (L (EpAnn @@ -350,11 +330,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (12411373583424111944) (NoSourceText)})))) (L (EpAnn @@ -415,11 +391,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "'MkT"))))))))) @@ -431,11 +403,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsInt{64}Prim (3) (NoSourceText)})))) (L (EpAnn @@ -562,11 +530,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (14073232900889011755) (NoSourceText)})))) (L (EpAnn @@ -576,11 +540,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (2739668351064589274) (NoSourceText)})))) (L (EpAnn @@ -641,11 +601,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "Peano"))))))))) @@ -657,11 +613,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsInt{64}Prim (0) (NoSourceText)})))) (L (EpAnn @@ -788,11 +740,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (13760111476013868540) (NoSourceText)})))) (L (EpAnn @@ -802,11 +750,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (12314848029315386153) (NoSourceText)})))) (L (EpAnn @@ -867,11 +811,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "'Zero"))))))))) @@ -883,11 +823,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsInt{64}Prim (0) (NoSourceText)})))) (L (EpAnn @@ -1014,11 +950,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (1143980031331647856) (NoSourceText)})))) (L (EpAnn @@ -1028,11 +960,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsWord{64}Prim (14802086722010293686) (NoSourceText)})))) (L (EpAnn @@ -1093,11 +1021,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "'Succ"))))))))) @@ -1109,11 +1033,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) {HsInt{64}Prim (0) (NoSourceText)})))) (L (EpAnn @@ -1175,11 +1095,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsInt (NoExtField) (IL @@ -1229,11 +1145,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsInt (NoExtField) (IL @@ -1283,11 +1195,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsInt (NoExtField) (IL @@ -2175,11 +2083,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "main"))))))))) @@ -2225,11 +2129,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsStringPrim (NoSourceText) "DumpTypecheckedAst"))))))))))) @@ -2372,11 +2272,7 @@ (EpaComments [])) (HsLit - (EpAnn - (EpaSpan { DumpTypecheckedAst.hs:20:17-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsString (SourceText "hello") {FastString: "hello"})))))))] ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -158,11 +158,7 @@ (EpaComments [])) (HsOverLit - (EpAnn - (EpaSpan { T20718.hs:8:5 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (OverLit (NoExtField) (HsIntegral ===================================== testsuite/tests/plugins/hooks-plugin/Hooks/MetaPlugin.hs ===================================== @@ -36,7 +36,7 @@ fakeRunMeta opts (MetaE r) _ = do pure $ r zero where zero :: LHsExpr GhcPs - zero = noLocA $ HsLit noAnn $ + zero = noLocA $ HsLit noExtField $ HsInt NoExtField (mkIntegralLit (0 :: Int)) fakeRunMeta _ _ _ = error "fakeRunMeta: unimplemented" ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2858,12 +2858,12 @@ instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsVar{}) = NoEntryVal - getAnnotationEntry (HsUnboundVar an _) = fromAnn an + getAnnotationEntry (HsUnboundVar{}) = NoEntryVal getAnnotationEntry (HsRecSel{}) = NoEntryVal getAnnotationEntry (HsOverLabel{}) = NoEntryVal - getAnnotationEntry (HsIPVar an _) = fromAnn an - getAnnotationEntry (HsOverLit an _) = fromAnn an - getAnnotationEntry (HsLit an _) = fromAnn an + getAnnotationEntry (HsIPVar{}) = NoEntryVal + getAnnotationEntry (HsOverLit{}) = NoEntryVal + getAnnotationEntry (HsLit{}) = NoEntryVal getAnnotationEntry (HsLam an _ _) = fromAnn an getAnnotationEntry (HsApp an _ _) = fromAnn an getAnnotationEntry (HsAppType _ _ _) = NoEntryVal @@ -2896,12 +2896,12 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsEmbTy{}) = NoEntryVal setAnnotationAnchor a@(HsVar{}) _ _ _s = a - setAnnotationAnchor (HsUnboundVar an a) anc ts cs = (HsUnboundVar (setAnchorEpa an anc ts cs) a) + setAnnotationAnchor a@(HsUnboundVar{}) _ _ _s = a setAnnotationAnchor a@(HsRecSel{}) _ _ _s = a setAnnotationAnchor a@(HsOverLabel{}) _ _ _s = a - setAnnotationAnchor (HsIPVar an a) anc ts cs = (HsIPVar (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsOverLit an a) anc ts cs = (HsOverLit (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsLit an a) anc ts cs = (HsLit (setAnchorEpa an anc ts cs) a) + setAnnotationAnchor a@(HsIPVar{}) _ _ _s = a + setAnnotationAnchor a@(HsOverLit {}) _ _ _s = a + setAnnotationAnchor a@(HsLit {}) _ _ _s = a setAnnotationAnchor (HsLam an a b) anc ts cs = (HsLam (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (HsApp an a b) anc ts cs = (HsApp (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsAppType {}) _ _ _s = a @@ -2943,7 +2943,7 @@ instance ExactPrint (HsExpr GhcPs) where return (HsVar x n') exact x@(HsUnboundVar an _) = do case an of - EpAnn _ (Just (EpAnnUnboundVar (ob,cb) l)) _ -> do + Just (EpAnnUnboundVar (ob,cb) l) -> do printStringAtAA ob "`" >> return () printStringAtAA l "_" >> return () printStringAtAA cb "`" >> return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6058c01186a35de4dcdb24452ca33d1d09a1ddca -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6058c01186a35de4dcdb24452ca33d1d09a1ddca 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 Dec 7 23:44:40 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 07 Dec 2023 18:44:40 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: testsuite: add test for #23944 Message-ID: <657258e883022_153177251d3bb426441a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 90dfa9e1 by Zubin Duggal at 2023-12-07T18:43:49-05:00 testsuite: add test for #23944 - - - - - 3335071c by Zubin Duggal at 2023-12-07T18:43:49-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. - - - - - ea367904 by Zubin Duggal at 2023-12-07T18:43:50-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 - - - - - 354bbf27 by Zubin Duggal at 2023-12-07T18:43:50-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 - - - - - 27486891 by Zubin Duggal at 2023-12-07T18:43:50-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 - - - - - 7b2c077a by Zubin Duggal at 2023-12-07T18:43:50-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 - - - - - 03789b49 by Zubin Duggal at 2023-12-07T18:43:50-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 70411d07 by Simon Peyton Jones at 2023-12-07T18:43:50-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - da7b278a by Simon Peyton Jones at 2023-12-07T18:43:51-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] - - - - - d639549f by Zubin Duggal at 2023-12-07T18:43:51-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 - - - - - 7a9cdad3 by Zubin Duggal at 2023-12-07T18:43:52-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - ed186746 by Wendao Lee at 2023-12-07T18:43:55-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> - - - - - e8131379 by Malik Ammar Faisal at 2023-12-07T18:43:58-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - 87e7fd75 by Simon Peyton Jones at 2023-12-07T18:43:59-05:00 Comments only in FloatIn Relevant to #3458 - - - - - 886d86a0 by Simon Peyton Jones at 2023-12-07T18:43:59-05:00 Comments only in SpecConstr - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/driver/all.T - + testsuite/tests/ghci/T23405/T23405.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412e120ce7d5528325125dd4250f0c1066b6da88...886d86a0dadcad19d22aa82fb1e4a82fb33aa84f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412e120ce7d5528325125dd4250f0c1066b6da88...886d86a0dadcad19d22aa82fb1e4a82fb33aa84f 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 Dec 8 05:06:17 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 00:06:17 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 15 commits: testsuite: add test for #23944 Message-ID: <6572a4492a2fe_1531772ca18f5c3121f2@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2b5252dd by Zubin Duggal at 2023-12-08T00:04:49-05:00 testsuite: add test for #23944 - - - - - afcf53e0 by Zubin Duggal at 2023-12-08T00:04:49-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. - - - - - 4d21b629 by Zubin Duggal at 2023-12-08T00:04:50-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 - - - - - bb60d183 by Zubin Duggal at 2023-12-08T00:04:50-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 - - - - - 6e4b4b15 by Zubin Duggal at 2023-12-08T00:04:50-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 - - - - - 17e44c31 by Zubin Duggal at 2023-12-08T00:04:50-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 - - - - - c7a2a4cd by Zubin Duggal at 2023-12-08T00:04:50-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - b7b1e8d4 by Simon Peyton Jones at 2023-12-08T00:04:51-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - 34c911a7 by Simon Peyton Jones at 2023-12-08T00:04:51-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] - - - - - e6fd5006 by Zubin Duggal at 2023-12-08T00:04:51-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 - - - - - 426cd31b by Zubin Duggal at 2023-12-08T00:04:52-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - db80cad5 by Wendao Lee at 2023-12-08T00:04:55-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> - - - - - 5f58a3a1 by Malik Ammar Faisal at 2023-12-08T00:04:59-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - c484e782 by Simon Peyton Jones at 2023-12-08T00:04:59-05:00 Comments only in FloatIn Relevant to #3458 - - - - - 5d8d8aab by Simon Peyton Jones at 2023-12-08T00:04:59-05:00 Comments only in SpecConstr - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/driver/all.T - + testsuite/tests/ghci/T23405/T23405.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/886d86a0dadcad19d22aa82fb1e4a82fb33aa84f...5d8d8aab7d724064699f8aa6227a908f6629c391 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/886d86a0dadcad19d22aa82fb1e4a82fb33aa84f...5d8d8aab7d724064699f8aa6227a908f6629c391 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 Dec 8 06:38:56 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 01:38:56 -0500 Subject: [Git][ghc/ghc][wip/24107] 13 commits: Only exit ghci in -e mode when :add command fails Message-ID: <6572ba00d25ea_1531772ec07f5031232f@gitlab.mail> Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - fa148f6e by Zubin Duggal at 2023-12-08T06:38:53+00: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 - - - - - a62d4cb2 by Zubin Duggal at 2023-12-08T06:38:53+00: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 - - - - - 244d3315 by Zubin Duggal at 2023-12-08T06:38:53+00: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 - - - - - 306cb4e3 by Zubin Duggal at 2023-12-08T06:38:53+00: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 - - - - - 77a3b580 by Zubin Duggal at 2023-12-08T06:38:53+00:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 30 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/Language/Haskell/Syntax/Expr.hs - ghc/GHCi/UI.hs - hadrian/src/Settings/Warnings.hs - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - testsuite/tests/ado/T22483.stderr - + testsuite/tests/core-to-stg/T14895.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd0db14c439d7dbacc39e0ec9e932eaea1993228...77a3b580f561e62f5ac7ebf6588199575aafd3b4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fd0db14c439d7dbacc39e0ec9e932eaea1993228...77a3b580f561e62f5ac7ebf6588199575aafd3b4 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 Dec 8 07:26:05 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 02:26:05 -0500 Subject: [Git][ghc/ghc][master] 2 commits: testsuite: add test for #23944 Message-ID: <6572c50d3c9c5_3478bc44870c6127@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 5 changed files: - compiler/GHC/Driver/Pipeline.hs - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - testsuite/tests/driver/all.T Changes: ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -788,7 +788,15 @@ hscBackendPipeline pipe_env hsc_env mod_sum result = if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result - when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do + -- Only run dynamic-too if the backend generates object files + -- See Note [Writing interface files] + -- If we are writing a simple interface (not . backendWritesFiles), then + -- hscMaybeWriteIface in the regular pipeline will write both the hi and + -- dyn_hi files. This way we can avoid running the pipeline twice and + -- generating a duplicate linkable. + -- We must not run the backend a second time with `dynamicNow` enable because + -- all the work has already been done in the first pipeline. + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result return res ===================================== testsuite/tests/driver/T23944.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23944 where +import T23944A + +$(foo) ===================================== testsuite/tests/driver/T23944.stderr ===================================== @@ -0,0 +1,2 @@ +[1 of 2] Compiling T23944A ( T23944A.hs, interpreted ) +[2 of 2] Compiling T23944 ( T23944.hs, nothing ) ===================================== testsuite/tests/driver/T23944A.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23944A where + +import Language.Haskell.TH + +foo :: DecsQ +foo = pure [] ===================================== testsuite/tests/driver/all.T ===================================== @@ -327,3 +327,4 @@ test('T22669', req_interp, makefile_test, []) test('T23339', req_c, makefile_test, []) test('T23339B', [extra_files(['T23339.hs']), req_c], makefile_test, []) test('T23613', normal, compile_and_run, ['-this-unit-id=foo']) +test('T23944', [unless(have_dynamic(), skip), extra_files(['T23944A.hs'])], multimod_compile, ['T23944 T23944A', '-fprefer-byte-code -fbyte-code -fno-code -dynamic-too -fwrite-interface']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57c391c463f26b7025df9b340ad98416cff1d2b2...6329d308eb00891674754c1f58f1ee2880305a36 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/57c391c463f26b7025df9b340ad98416cff1d2b2...6329d308eb00891674754c1f58f1ee2880305a36 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 Dec 8 07:27:23 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 02:27:23 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: testsuite: add test for #23944 Message-ID: <6572c55b9d499_3478bc11941463681@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 261d71e1 by Simon Peyton Jones at 2023-12-08T02:27:00-05:00 Improve duplicate elimination in SpecConstr This partially fixes #24229. See the new Note [Pattern duplicate elimination] in SpecConstr - - - - - d441a432 by Simon Peyton Jones at 2023-12-08T02:27:00-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] - - - - - 05065949 by Zubin Duggal at 2023-12-08T02:27:01-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 - - - - - 990b16e8 by Zubin Duggal at 2023-12-08T02:27:01-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 9c79d663 by Wendao Lee at 2023-12-08T02:27:04-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> - - - - - 22b5f3be by Malik Ammar Faisal at 2023-12-08T02:27:10-05:00 Fix float parsing in GHC Cmm Lexer Add test case for bug #24224 - - - - - 59eef0a7 by Simon Peyton Jones at 2023-12-08T02:27:10-05:00 Comments only in FloatIn Relevant to #3458 - - - - - b1b7fdae by Simon Peyton Jones at 2023-12-08T02:27:10-05:00 Comments only in SpecConstr - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Tc/Utils/TcType.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/driver/all.T - testsuite/tests/perf/compiler/all.T - + testsuite/tests/simplCore/should_compile/T23209.hs - + testsuite/tests/simplCore/should_compile/T23209_Aux.hs - + testsuite/tests/simplCore/should_compile/T24229a.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d8d8aab7d724064699f8aa6227a908f6629c391...b1b7fdae4d5d07939ecd18628438f2495fa90568 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5d8d8aab7d724064699f8aa6227a908f6629c391...b1b7fdae4d5d07939ecd18628438f2495fa90568 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 Dec 8 08:16:06 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Fri, 08 Dec 2023 03:16:06 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] Fix TrivColorable register counts Message-ID: <6572d0c6538a5_3478bc1fcc1b8795f0@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: ba3b2d60 by Sven Tennie at 2023-12-08T09:13:14+01:00 Fix TrivColorable register counts - - - - - 1 changed file: - compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs ===================================== @@ -115,7 +115,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" ArchS390X -> panic "trivColorable ArchS390X" - ArchRISCV64 -> 15 + ArchRISCV64 -> 14 ArchLoongArch64->panic "trivColorable ArchLoongArch64" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchWasm32 -> panic "trivColorable ArchWasm32" @@ -184,7 +184,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel" ArchS390X -> panic "trivColorable ArchS390X" - ArchRISCV64 -> 26 + ArchRISCV64 -> 20 ArchLoongArch64->panic "trivColorable ArchLoongArch64" ArchJavaScript-> panic "trivColorable ArchJavaScript" ArchWasm32 -> panic "trivColorable ArchWasm32" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba3b2d609c1908876ca68d7dec6b83c4a71f7757 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba3b2d609c1908876ca68d7dec6b83c4a71f7757 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 Dec 8 08:52:54 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 03:52:54 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/multilayerth-darwin-fix Message-ID: <6572d96644eb5_3478bc2bd30b0803f9@gitlab.mail> Zubin pushed new branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/multilayerth-darwin-fix 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 Dec 8 08:56:18 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 03:56:18 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin-fix] wipo Message-ID: <6572da3222127_3478bc2f454a083458@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC Commits: e01f8c8f by Zubin Duggal at 2023-12-08T14:26:11+05:30 wipo - - - - - 1 changed file: - .gitlab-ci.yml The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e01f8c8ff1013f379b1a4c0e7785156082d1ee9d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e01f8c8ff1013f379b1a4c0e7785156082d1ee9d 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 Dec 8 09:20:49 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 04:20:49 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin-fix] wipo Message-ID: <6572dff1b8b7c_3478bc339721089774@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC Commits: d600cc6a by Zubin Duggal at 2023-12-08T14:50:43+05:30 wipo - - - - - 1 changed file: - .gitlab-ci.yml The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d600cc6acb933a47b4cd677dffe0e021ecfeea20 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d600cc6acb933a47b4cd677dffe0e021ecfeea20 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 Dec 8 09:23:09 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 04:23:09 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin-fix] wipo Message-ID: <6572e07db352b_3478bc382b95c904e9@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC Commits: 7cefbff1 by Zubin Duggal at 2023-12-08T14:53:03+05:30 wipo - - - - - 1 changed file: - .gitlab-ci.yml The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cefbff13531091ddd995ec2ef98d312b8b478a3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cefbff13531091ddd995ec2ef98d312b8b478a3 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 Dec 8 09:24:39 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 04:24:39 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin-fix] wipo Message-ID: <6572e0d73d2ca_3478bc382b95c90995@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC Commits: 3c915267 by Zubin Duggal at 2023-12-08T14:54:02+05:30 wipo - - - - - 1 changed file: - .gitlab-ci.yml The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c9152670406d883010886d92dc5a3b8464528db -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c9152670406d883010886d92dc5a3b8464528db 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 Dec 8 09:49:31 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 08 Dec 2023 04:49:31 -0500 Subject: [Git][ghc/ghc][wip/multilayerth-darwin-fix] wipo Message-ID: <6572e6ab928_3478bc40c010895884@gitlab.mail> Zubin pushed to branch wip/multilayerth-darwin-fix at Glasgow Haskell Compiler / GHC Commits: 71bb807b by Zubin Duggal at 2023-12-08T15:19:25+05:30 wipo - - - - - 1 changed file: - .gitlab-ci.yml The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71bb807b74b60825c8994722f38bab54839a45ce -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71bb807b74b60825c8994722f38bab54839a45ce 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 Dec 8 10:35:52 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Fri, 08 Dec 2023 05:35:52 -0500 Subject: [Git][ghc/ghc][wip/T24190] Allow untyped brackets in typed splices and vice versa. Message-ID: <6572f188d8650_3478bc54e51381001e6@gitlab.mail> Oleg Grenrus pushed to branch wip/T24190 at Glasgow Haskell Compiler / GHC Commits: afe3e120 by Oleg Grenrus at 2023-12-08T12:35:43+02: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. - - - - - 6 changed files: - compiler/GHC/Rename/Splice.hs - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,38 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +125,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +154,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -598,3 +598,4 @@ test('T23968', normal, compile_and_run, ['']) test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/afe3e1203a963743a1f1b34d13c95438350e89a1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/afe3e1203a963743a1f1b34d13c95438350e89a1 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 Dec 8 10:43:33 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 08 Dec 2023 05:43:33 -0500 Subject: [Git][ghc/ghc][wip/spj-comments] Add test for #22238 Message-ID: <6572f3556438b_3478bc574b7b0100616@gitlab.mail> Simon Peyton Jones pushed to branch wip/spj-comments at Glasgow Haskell Compiler / GHC Commits: 116e7b79 by Simon Peyton Jones at 2023-12-08T10:43:03+00:00 Add test for #22238 - - - - - 2 changed files: - + testsuite/tests/quantified-constraints/T22238.hs - testsuite/tests/quantified-constraints/all.T Changes: ===================================== testsuite/tests/quantified-constraints/T22238.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE GADTs #-} + +module T22238 where + +import Data.Kind (Constraint) + +data Dict (c :: Constraint) where + MkDict :: c => Dict c + +forallListEqDict :: Dict (forall a. Eq a => Eq [a]) +forallListEqDict = MkDict ===================================== testsuite/tests/quantified-constraints/all.T ===================================== @@ -44,3 +44,4 @@ test('T19690', normal, compile_fail, ['']) test('T23143', normal, compile, ['']) test('T23333', normal, compile, ['']) test('T23323', normal, compile, ['']) +test('T22238', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/116e7b790c25b47877b6b1a7c47c0cbf0257fe1e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/116e7b790c25b47877b6b1a7c47c0cbf0257fe1e 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 Dec 8 10:48:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 05:48:01 -0500 Subject: [Git][ghc/ghc][master] 2 commits: Improve duplicate elimination in SpecConstr Message-ID: <6572f46171c8d_3478bc56ac7641096e5@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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] - - - - - 16 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Tc/Utils/TcType.hs - + testsuite/tests/simplCore/should_compile/T23209.hs - + testsuite/tests/simplCore/should_compile/T23209_Aux.hs - + testsuite/tests/simplCore/should_compile/T24229a.hs - + testsuite/tests/simplCore/should_compile/T24229a.stderr - + testsuite/tests/simplCore/should_compile/T24229b.hs - + testsuite/tests/simplCore/should_compile/T24229b.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -1237,9 +1237,8 @@ See also Note [Return type for join points] and Note [Join points and case-of-ca -} getSubst :: SimplEnv -> Subst -getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkSubst in_scope tv_env cv_env emptyIdSubstEnv +getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = mkTCvSubst in_scope tv_env cv_env substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getSubst env) ty ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -67,7 +67,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) -import GHC.Data.Pair import GHC.Data.FastString import GHC.Utils.Misc @@ -81,8 +80,8 @@ import GHC.Builtin.Names ( specTyConKey ) import GHC.Exts( SpecConstrAnnotation(..) ) import GHC.Serialized ( deserializeWithData ) -import Control.Monad ( zipWithM ) -import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) +import Control.Monad +import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL ) import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) import Data.Tuple @@ -2246,7 +2245,7 @@ Wrinkles: * The list of argument patterns, cp_args, is no longer than the visible lambdas of the binding, ri_arg_occs. This is done via - the zipWithM in callToPats. + the zipWithM in callToPat. * The list of argument patterns can certainly be shorter than the lambdas in the function definition (under-saturated). For example @@ -2256,7 +2255,7 @@ Wrinkles: * In fact we deliberately shrink the list of argument patterns, cp_args, by trimming off all the boring ones at the end (see - `dropWhileEnd is_boring` in callToPats). Since the RULE only + `dropWhileEnd is_boring` in callToPat). Since the RULE only applies when it is saturated, this shrinking makes the RULE more applicable. But it does mean that the argument patterns do not necessarily saturate the lambdas of the function. @@ -2299,63 +2298,48 @@ Note [SpecConstr and casts] Consider (#14270) a call like let f = e - in ... f (K @(a |> co)) ... + in ... f (K @(a |> cv)) ... -where 'co' is a coercion variable not in scope at f's definition site. +where 'cv' is a coercion variable not in scope at f's definition site. If we aren't careful we'll get - let $sf a co = e (K @(a |> co)) - RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co + let $sf a cv = e (K @(a |> cv)) + RULE "SC:f" forall a cv. f (K @(a |> cv)) = $sf a co f = e in ... -But alas, when we match the call we won't bind 'co', because type-matching -(for good reasons) discards casts). - -I don't know how to solve this, so for now I'm just discarding any -call patterns that - * Mentions a coercion variable in a type argument - * That is not in scope at the binding of the function - -I think this is very rare. - -It is important (e.g. #14936) that this /only/ applies to -coercions mentioned in casts. We don't want to be discombobulated -by casts in terms! For example, consider - f ((e1,e2) |> sym co) -where, say, - f :: Foo -> blah - co :: Foo ~R (Int,Int) - -Here we definitely do want to specialise for that pair! We do not -match on the structure of the coercion; instead we just match on a -coercion variable, so the RULE looks like - - forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) - f ((x,y) |> co) = $sf x y co - -Often the body of f looks like - f arg = ...(case arg |> co' of - (x,y) -> blah)... - -so that the specialised f will turn into - $sf x y co = let arg = (x,y) |> co - in ...(case arg>| co' of - (x,y) -> blah).... - -which will simplify to not use 'co' at all. But we can't guarantee -that co will end up unused, so we still pass it. Absence analysis -may remove it later. - -Note that this /also/ discards the call pattern if we have a cast in a -/term/, although in fact Rules.match does make a very flaky and -fragile attempt to match coercions. e.g. a call like - f (Maybe Age) (Nothing |> co) blah - where co :: Maybe Int ~ Maybe Age -will be discarded. It's extremely fragile to match on the form of a -coercion, so I think it's better just not to try. A more complicated -alternative would be to discard calls that mention coercion variables -only in kind-casts, but I'm doing the simple thing for now. +But alas, when we match the call we may fail to bind 'co', because the rule +matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear +in casts (see Note [Casts in the template] in GHC.Core.Rules). + +This seems intractable (see #23209). So: + +* Key point: we /never/ quantify over coercion variables in a SpecConstr rule. + If we would need to quantify over a coercion variable, we just discard the + call pattern. See the test for `bad_covars` in callToPat. + +* However (#14936) we /do/ still allow casts in call patterns. For example + f ((e1,e2) |> sym co) + where, say, + f :: Foo -> blah -- Foo is a newtype + f = f_rhs + co :: Foo ~R (Int,Int) + We want to specialise on that pair! + +So for our function f, we might generate + RULE forall x y. f ((x,y) |> co) = $sf x y + $sf x y = f_rhs ((x,y) |> co) + +This works provided the free vars of `co` are either in-scope at the +definition of `f`, or quantified. For the latter, suppose `f` was polymorphic: + + f2 :: Foo2 a -> blah -- Foo is a newtype + f2 = f2_rhs + co2 :: Foo a ~R (a,a) + +Then it's fine for `co2` to mention `a`. We'll get + RULE forall a (x::a) (y::a). f2 @a ((x,y) |> co2) = $sf2 a x y + $sf2 @a x y = f2_rhs ((x,y) |> co2) -} data CallPat = CP { cp_qvars :: [Var] -- Quantified variables @@ -2381,19 +2365,23 @@ callsToNewPats :: ScEnv -> Id -- The "New" in the name means "patterns that are not already covered -- by an existing specialisation" callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls + = do { mb_pats <- mapM (callToPat env bndr_occs) calls ; let have_boring_call = any isNothing mb_pats good_pats :: [CallPat] good_pats = catMaybes mb_pats + in_scope = getSubstInScope (sc_subst env) + -- Remove patterns we have already done new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs + is_done p = any is_better done_specs + where + is_better done = betterPat in_scope (os_pat done) p -- Remove duplicates - non_dups = nubBy samePat new_pats + non_dups = subsumePats in_scope new_pats -- Remove ones that have too many worker variables small_pats = filterOut too_many_worker_args non_dups @@ -2410,6 +2398,10 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats -- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "good_pats:" <+> ppr good_pats +-- , text "new_pats:" <+> ppr new_pats +-- , text "non_dups:" <+> ppr non_dups +-- , text "small_pats:" <+> ppr small_pats -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "trimmed_pats:" <+> ppr trimmed_pats ]) @@ -2477,12 +2469,12 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) +callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- The [Var] is the variables to quantify over in the rule -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call fn args con_env) +callToPat env bndr_occs call@(Call fn args con_env) = do { let in_scope = getSubstInScope (sc_subst env) ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) @@ -2513,32 +2505,25 @@ callToPats env bndr_occs call@(Call fn args con_env) -- See Note [Free type variables of the qvar types] -- See Note [Shadowing] at the top - (ktvs, ids) = partition isTyVar qvars - qvars' = scopedSort ktvs ++ map sanitise ids + (qktvs, qids) = partition isTyVar qvars + qvars' = scopedSort qktvs ++ map sanitise qids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = updateIdTypeAndMult expandTypeSynonyms id + sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] - -- Check for bad coercion variables: see Note [SpecConstr and casts] - ; let bad_covars :: CoVarSet - bad_covars = mapUnionVarSet get_bad_covars pats - get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty) - get_bad_covars _ = emptyVarSet - bad_covar v = isId v && not (is_in_scope v) - - ; warnPprTrace (not (isEmptyVarSet bad_covars)) + ; let bad_covars = filter isCoVar qids + ; warnPprTrace (not (null bad_covars)) "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ - if interesting && isEmptyVarSet bad_covars + if interesting && null bad_covars then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats , cp_strict_args = concat cbv_ids } --- ; pprTraceM "callToPatsOut" $ +-- ; pprTraceM "callToPatOut" $ -- vcat [ text "fn:" <+> ppr fn -- , text "args:" <+> ppr args -- , text "bndr_occs:" <+> ppr bndr_occs @@ -2606,39 +2591,16 @@ argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str -- Here we can specialise for f (v,w) -- because the rule-matcher will look through the let. -{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" - = argToPat env in_scope val_env rhs arg_occ --} - + -- Casts: see Note [SpecConstr and casts] argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str ; if not interesting then wildCardPat ty2 arg_str - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } } + else + return (interesting, Cast arg' co, strict_args) } where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) - where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} + ty2 = coercionRKind co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs @@ -2727,6 +2689,25 @@ argToPat1 env in_scope val_env (Var v) arg_occ arg_str -- f x y = letrec g z = ... in g (x,y) -- We don't want to specialise for that *particular* x,y + +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + = argToPat env in_scope val_env rhs arg_occ +-} + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + -- The default case: make a wild-card -- We use this for coercions too argToPat1 _env _in_scope _val_env arg _arg_occ arg_str @@ -2790,40 +2771,69 @@ valueIsWorkFree :: Value -> Bool valueIsWorkFree LambdaVal = True valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args -samePat :: CallPat -> CallPat -> Bool -samePat (CP { cp_qvars = vs1, cp_args = as1 }) - (CP { cp_qvars = vs2, cp_args = as2 }) - = all2 same as1 as2 +betterPat :: InScopeSet -> CallPat -> CallPat -> Bool +-- pat1 f @a (Just @a (x::a)) +-- is better than +-- pat2 f @Int (Just @Int (x::Int)) +-- That is, we can instantiate pat1 to get pat2 +-- See Note [Pattern duplicate elimination] +betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) + (CP { cp_qvars = vs2, cp_args = as2 }) + = case matchExprs ise vs1 as1 as2 of + Just (_, ms) -> all exprIsTrivial ms + Nothing -> False + where + ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding) + +subsumePats :: InScopeSet -> [CallPat] -> [CallPat] +-- Remove any patterns subsumed by others +-- See Note [Pattern duplicate elimination] +subsumePats is pats = foldr add [] pats where - -- If the args are the same, their strictness marks will be too so we don't compare those. - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 - - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 - - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 - - same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $ - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False + add :: CallPat -> [CallPat] -> [CallPat] + add ci [] = [ci] + add ci1 (ci2:cis) | betterPat is ci2 ci1 = ci2:cis + | betterPat is ci1 ci2 = ci1:cis + | otherwise = ci2 : add ci1 cis {- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. +Note [Pattern duplicate elimination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: (a,a) -> blah, and two calls + f @Int (x,y) + f @Bool (p,q) + +The danger is that we'll generate two *essentially identical* specialisations, +both for pairs, but with different types instantiating `a` (see #24229). + +But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises +that argument. So SpecConstr should never need to specialise f's polymorphic +type arguments. Even with only one of these calls we should be able to +generalise to the `CallPat` + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + +Doing so isn't trivial, though. + +For now we content ourselves with a simpler plan: eliminate a call pattern +if another pattern subsumes it; this is done by `subsumePats`. +For example here are two patterns + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)] + +The first can be instantiated to the second, /by instantiating types only/. +This subsumption relationship is checked by `betterPat`. Note that if +we have + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [], cp_args = [@Bool (True,False)] + +the first does *not* subsume the second; the second is more specific. + +In our initial example with `f @Int` and `f @Bool` neither subsumes the other, +so we will get two essentially-identical specialisations. Boo. We rely on our +crude throttling mechanisms to stop this getting out of control -- with +polymorphic recursion we can generate an infinite number of specialisations. +Example is Data.Sequence.adjustTree, I think. -} ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( -- ** Looking up rules - lookupRule, + lookupRule, matchExprs, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -86,6 +86,7 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.List.SetOps( hasNoDups ) +import GHC.Utils.FV( filterFV, fvVarSet ) import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic @@ -720,15 +721,23 @@ matchN :: InScopeEnv -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs +matchN ise _rule_name tmpl_vars tmpl_es target_es rhs + = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + +matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] + -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] +matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - bind_wrapper = rs_binds rule_subst + + ; let bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } + + ; return (bind_wrapper, matched_es) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] @@ -739,7 +748,7 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs , rv_unf = id_unf } lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) - -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + -- Need to return a RuleSubst solely for the benefit of fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) | isId tmpl_var1 @@ -768,7 +777,6 @@ matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs unbound tmpl_var = pprPanic "Template variable unbound in rewrite rule" $ vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) - , text "Rule" <+> pprRuleName rule_name , text "Rule bndrs:" <+> ppr tmpl_vars , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] @@ -960,45 +968,78 @@ where 'co' is non-reflexive, we simply fail. You might wonder about but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~ -What if we have (f co) in the template, where the 'co' is a coercion -argument to f? Right now we have nothing in place to ensure that a -coercion /argument/ in the template is a variable. We really should, -perhaps by abstracting over that variable. - -C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. - -For now, though, we simply behave badly, by failing in match_co. -We really should never rely on matching the structure of a coercion -(which is just a proof). - Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the definition +This Note concerns `matchTemplateCast`. Consider the definition f x = e, and SpecConstr on call pattern f ((e1,e2) |> co) -We'll make a RULE +The danger is that We'll make a RULE RULE forall a,b,g. f ((a,b)|> g) = $sf a b g $sf a b g = e[ ((a,b)|> g) / x ] -So here is the invariant: +This requires the rule-matcher to bind the coercion variable `g`. +That is Very Deeply Suspicious: + +* It would be unreasonable to match on a structured coercion in a pattern, + such as RULE forall g. f (x |> Sym g) = ... + because the strucure of a coercion is arbitrary and may change -- it's their + /type/ that matters. + +* We considered insisting that in a template, in a cast (e |> co), the the cast + `co` is always a /variable/ cv. That looks a bit more plausible, but #23209 + (and related tickets) shows that it's very fragile. For example suppose `e` + is a variable `f`, and the simplifier has an unconditional substitution + [f :-> g |> co2] + Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! + +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion +variable. And SpecConstr no longer does so: see Note [SpecConstr and casts] in +SpecConstr. - In the template, in a cast (e |> co), - the cast `co` is always a /variable/. +It is, however, OK for a cast to appear in a template. For example + newtype N a = MkN (a,a) -- Axiom ax:N a :: (a,a) ~R N a + f :: N a -> bah + RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ... -Matching should bind that variable to an actual coercion, so that we -can use it in $sf. So a Cast on the LHS (the template) calls -match_co, which succeeds when the template cast is a variable -- which -it always is. That is why match_co has so few cases. +When matching we can just move these casts to the other side: + match (tmpl |> co) tgt --> match tmpl (tgt |> sym co) +See matchTemplateCast. + +Wrinkles: + +(CT1) We need to be careful about scoping, and to match left-to-right, so that we + know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we + can apply that substitition + +(CT2) Annoyingly, we still want support one case in which the RULE quantifies + over a coercion variable: the dreaded map/coerce RULE. + See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + + Since that can happen, matchTemplateCast laboriously checks whether the + coercion mentions a template coercion variable; and if so does the Very Deeply + Suspicious `match_co` instead. It works fine for map/coerce, where the + coercion is always a variable and will (robustly) remain so. See also * Note [Coercion arguments] * Note [Matching coercion variables] in GHC.Core.Unify. * Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: sm_cast_swizzle is switched off in the template of a RULE + +Note [Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~ +What if we have (f (Coercion co)) in the template, where the 'co' is a coercion +argument to f? Right now we have nothing in place to ensure that a +coercion /argument/ in the template is a variable. We really should, +perhaps by abstracting over that variable. + +C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. + +For now, though, we simply behave badly, by failing in match_co. +We really should never rely on matching the structure of a coercion +(which is just a proof). -} ---------------------- @@ -1060,14 +1101,7 @@ match renv subst e1 (Cast e2 co2) mco -- This is important: see Note [Cancel reflexive casts] match renv subst (Cast e1 co1) e2 mco - = -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 - ; subst1 <- match_co renv subst co1 co2 - -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } + = matchTemplateCast renv subst e1 co1 e2 mco ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco @@ -1290,7 +1324,7 @@ match renv subst (Lam x1 e1) e2 mco in_scope_env = ISE in_scope (rv_unf renv) -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily -- a superset of the free vars of e2; it is only guaranteed a superset of - -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe + -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe -- wants an in-scope set that includes all the free vars of its argument. -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630) , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 @@ -1449,6 +1483,40 @@ Hence -} ------------- +matchTemplateCast + :: RuleMatchEnv -> RuleSubst + -> CoreExpr -> Coercion + -> CoreExpr -> MCoercion + -> Maybe RuleSubst +matchTemplateCast renv subst e1 co1 e2 mco + | isEmptyVarSet $ fvVarSet $ + filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not + tyCoFVsOfCo substed_co -- mention any of the template variables + = -- This is the good path + -- See Note [Casts in the template] + match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + + | otherwise + = -- This is the Deeply Suspicious Path + do { let co2 = case mco of + MRefl -> mkRepReflCo (exprType e2) + MCo co2 -> co2 + ; subst1 <- match_co renv subst co1 co2 + -- If match_co succeeds, then (exprType e1) = (exprType e2) + -- Hence the MRefl in the next line + ; match renv subst1 e1 e2 MRefl } + where + substed_co = substCo current_subst co1 + + current_subst :: Subst + current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) + (rs_tv_subst subst) + emptyCvSubstEnv + -- emptyCvSubstEnv: ugh! + -- If there were any CoVar substitutions they would be in + -- rs_id_subst; but we don't expect there to be any; see + -- Note [Casts in the template] + match_co :: RuleMatchEnv -> RuleSubst -> Coercion ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -818,35 +818,40 @@ The naive core produced for this is This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding +too. Achieving all this is surprisingly tricky: - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... +(MC1) We must compulsorily unfold MkAge to a cast. + See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: +(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... - -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) - - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... - -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: + Getting better. But this isn't exactly what gets produced. This is because + Coercible essentially has ~R# as a superclass, and superclasses get eagerly + extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + + Unfortunately, this still abstracts over a Coercible dictionary. We really + want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, + which transforms the above to + Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + + See Note [Desugaring coerce as cast] in GHC.HsToCore + +(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three + separate actions: 1. Inline certain non-recursive bindings. The choice whether to inline is made in simple_bind_pair. Note the rather specific check for MkCoercible in there. @@ -858,6 +863,10 @@ separate actions: just packed and inline them. This is also done in simple_opt_expr's `go` function. +(MC4) The map/coerce rule is the only compelling reason for having a RULE that + quantifies over a coercion variable, something that is otherwise Very Deeply + Suspicous. See Note [Casts in the template] in GHC.Core.Rules. Ugh! + This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across. ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Core.Subst ( substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, + emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendIdSubstWithClone, extendSubst, extendSubstList, extendSubstWithVar, ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Core.TyCo.Subst Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, - mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst, getTvSubstEnv, getIdSubstEnv, getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, isInScope, elemSubst, notElemSubst, zapSubst, @@ -271,8 +271,8 @@ isEmptyTCvSubst :: Subst -> Bool isEmptyTCvSubst (Subst _ _ tv_env cv_env) = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs +mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst +mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -198,7 +198,7 @@ module GHC.Core.Type ( -- ** Manipulating type substitutions emptyTvSubstEnv, emptySubst, mkEmptySubst, - mkSubst, zipTvSubst, mkTvSubstPrs, + mkTCvSubst, zipTvSubst, mkTvSubstPrs, zipTCvSubst, notElemSubst, getTvSubstEnv, ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -1481,7 +1481,7 @@ getSubst :: UMEnv -> UM Subst getSubst env = do { tv_env <- getTvSubstEnv ; cv_env <- getCvSubstEnv ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } + ; return (mkTCvSubst in_scope tv_env cv_env) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -166,7 +166,7 @@ module GHC.Tc.Utils.TcType ( extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, ===================================== testsuite/tests/simplCore/should_compile/T23209.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} + +-- This gave a Lint crash + +module T23209 where + +import T23209_Aux + +f a = let w = if a then Allocator (ArrayWriter s) + else Allocator (ArrayWriter e) + in case combine w w of ===================================== testsuite/tests/simplCore/should_compile/T23209_Aux.hs ===================================== @@ -0,0 +1,19 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -O #-} +module T23209_Aux where + +newtype I = MkI { uI :: () -> () } +newtype ArrayWriter = ArrayWriter (() -> I) +data Allocator = Allocator !ArrayWriter + +combine :: Allocator -> Allocator -> (# () -> () #) +combine (Allocator (ArrayWriter w1)) (Allocator (ArrayWriter w2)) = + (# \s -> id' (uI (w1 ()) (uI (w2 ()) s)) #) + +e, s :: () -> I +e x = MkI id +s x = MkI id +{-# NOINLINE s #-} + +id' :: () -> () +id' x = x ===================================== testsuite/tests/simplCore/should_compile/T24229a.hs ===================================== @@ -0,0 +1,14 @@ +module T24229a where + +newtype N a = MkN a + +foo :: Int -> N (a,a) -> Maybe (a,a) +foo 0 (MkN p) = Just p +foo n (MkN (x,y)) = foo (n-1) (MkN (y,x)) + +-- We should generate ONE specialisation for $wfoo, +-- and it should fire TWICE, regardless of the order +-- of the following two definitions. + +wombat1 = foo 20 (MkN ("yes", "no")) +wombat2 xs ys = foo 3 (MkN (xs, ys)) ===================================== testsuite/tests/simplCore/should_compile/T24229a.stderr ===================================== @@ -0,0 +1,38 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 79, types: 106, coercions: 8, joins: 0/0} + +Rec { +foo_$s$wfoo + = \ @a sc sc1 sc2 -> + case sc2 of ds { + __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#); + 0# -> (# (sc, sc1) #) + } +end Rec } + +foo + = \ @a ds ds1 -> + case ds of { I# ww -> + case ww of ds2 { + __DEFAULT -> case ds1 `cast` :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } }; + 0# -> Just (ds1 `cast` :: ...) + } + } + +wombat7 = "yes"# + +wombat6 = unpackCString# wombat7 + +wombat5 = "no"# + +wombat4 = unpackCString# wombat5 + +wombat1 = case foo_$s$wfoo wombat6 wombat4 20# of { (# ww #) -> Just ww } + +wombat8 = I# 3# + +wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww } + + + ===================================== testsuite/tests/simplCore/should_compile/T24229b.hs ===================================== @@ -0,0 +1,13 @@ +module T24229b where + +newtype N a = MkN a + +foo :: Int -> N (a,a) -> Maybe (a,a) +foo 0 (MkN p) = Just p +foo n (MkN (x,y)) = foo (n-1) (MkN (y,x)) + +-- We should generate ONE specialisation for $wfoo, +-- and it should fire TWICE, regardless of the order +-- of the following two definitions. + +wombat2 xs ys = foo 3 (MkN (xs, ys)) ===================================== testsuite/tests/simplCore/should_compile/T24229b.stderr ===================================== @@ -0,0 +1,28 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 60, types: 83, coercions: 8, joins: 0/0} + +Rec { +foo_$s$wfoo + = \ @a sc sc1 sc2 -> + case sc2 of ds { + __DEFAULT -> foo_$s$wfoo sc1 sc (-# ds 1#); + 0# -> (# (sc, sc1) #) + } +end Rec } + +foo + = \ @a ds ds1 -> + case ds of { I# ww -> + case ww of ds2 { + __DEFAULT -> case ds1 `cast` :: ... of { (x, y) -> case foo_$s$wfoo y x (-# ds2 1#) of { (# ww1 #) -> Just ww1 } }; + 0# -> Just (ds1 `cast` :: ...) + } + } + +wombat1 = I# 3# + +wombat2 = \ @a xs ys -> case foo_$s$wfoo xs ys 3# of { (# ww #) -> Just ww } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -508,4 +508,6 @@ test('T24014', normal, compile, ['-dcore-lint']) test('T24029', normal, compile, ['']) test('T21348', normal, compile, ['-O']) test('T21917', normal, compile, ['-O -fkeep-auto-rules -ddump-rules']) - +test('T23209', [extra_files(['T23209_Aux.hs'])], multimod_compile, ['T23209', '-v0 -O']) +test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999']) +test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6329d308eb00891674754c1f58f1ee2880305a36...fec7894f74a2f1c6f12f52dab82f8765c037b937 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6329d308eb00891674754c1f58f1ee2880305a36...fec7894f74a2f1c6f12f52dab82f8765c037b937 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 Dec 8 10:48:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 05:48:34 -0500 Subject: [Git][ghc/ghc][master] driver: Don't lose track of nodes when we fail to resolve cycles Message-ID: <6572f48227064_3478bc56ac7641145fb@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 6 changed files: - compiler/GHC/Driver/Make.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T Changes: ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -608,7 +608,7 @@ createBuildPlan mod_graph maybe_top_mod = -- Now perform another toposort but just with these nodes and relevant hs-boot files. -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. mresolved_cycle = collapseSCC (topSortWithBoot nodes) - in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] + in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload) @@ -639,12 +639,12 @@ createBuildPlan mod_graph maybe_top_mod = get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing -- Any cycles should be resolved now - collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] + collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle - collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2] + collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes -- Cyclic - collapseSCC _ = Nothing + collapseSCC nodes = Left (flattenSCCs nodes) toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile toNodeWithBoot mn = ===================================== testsuite/tests/driver/T24196/T24196.stderr ===================================== @@ -0,0 +1,4 @@ +Module graph contains a cycle: + module ‘T24196A’ (./T24196A.hs-boot) + imports module ‘T24196B’ (T24196B.hs) + which imports module ‘T24196A’ (./T24196A.hs-boot) ===================================== testsuite/tests/driver/T24196/T24196A.hs ===================================== @@ -0,0 +1 @@ +module T24196A where ===================================== testsuite/tests/driver/T24196/T24196A.hs-boot ===================================== @@ -0,0 +1,3 @@ +module T24196A where + +import T24196B ===================================== testsuite/tests/driver/T24196/T24196B.hs ===================================== @@ -0,0 +1,3 @@ +module T24196B where + +import {-# SOURCE #-} T24196A ===================================== testsuite/tests/driver/T24196/all.T ===================================== @@ -0,0 +1 @@ +test('T24196', extra_files(['T24196A.hs','T24196A.hs-boot','T24196B.hs']), multimod_compile_fail, ['T24196B','']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8db8d2fd1c881032b1b360c032b6d9d072c11723 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8db8d2fd1c881032b1b360c032b6d9d072c11723 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 Dec 8 10:49:10 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 05:49:10 -0500 Subject: [Git][ghc/ghc][master] testsuite: Skip MultiLayerModulesTH_OneShot on darwin Message-ID: <6572f4a6c8f8e_3478bc5eea4e411763b@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c5b4efd3 by Zubin Duggal at 2023-12-08T05:48:30-05:00 testsuite: Skip MultiLayerModulesTH_OneShot on darwin See #24177 - - - - - 1 changed file: - testsuite/tests/perf/compiler/all.T Changes: ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -372,7 +372,10 @@ test('MultiLayerModulesTH_OneShot', pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'), extra_files(['genMultiLayerModulesTH']), unless(have_dynamic(),skip), - compile_timeout_multiplier(5) + compile_timeout_multiplier(5), + # We skip the test on darwin due to recent regression due to toolchain + # upgrade (tracked in #24177) + when(opsys('darwin'), skip) ], compile_fail, # see Note [Increased initial stack size for MultiLayerModules] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5b4efd39786b38bb3a8713233317a8daf2b33db -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c5b4efd39786b38bb3a8713233317a8daf2b33db 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 Dec 8 10:49:47 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 05:49:47 -0500 Subject: [Git][ghc/ghc][master] docs(Data.Char):Add more detailed descriptions for some functions Message-ID: <6572f4cb98bba_3478bc5a40330120767@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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> - - - - - 1 changed file: - libraries/base/src/GHC/Unicode.hs Changes: ===================================== libraries/base/src/GHC/Unicode.hs ===================================== @@ -208,6 +208,17 @@ isControl c = case generalCategory c of -- | Selects printable Unicode characters -- (letters, numbers, marks, punctuation, symbols and spaces). +-- +-- This function returns 'False' if its argument has one of the +-- following 'GeneralCategory's, or 'True' otherwise: +-- +-- * 'LineSeparator' +-- * 'ParagraphSeparator' +-- * 'Control' +-- * 'Format' +-- * 'Surrogate' +-- * 'PrivateUse' +-- * 'NotAssigned' isPrint :: Char -> Bool isPrint c = case generalCategory c of LineSeparator -> False @@ -302,6 +313,20 @@ isLowerCase = DCP.isLowercase -- | Selects alphabetic Unicode characters (lower-case, upper-case and -- title-case letters, plus letters of caseless scripts and modifiers letters). -- This function is equivalent to 'Data.Char.isLetter'. +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'UppercaseLetter' +-- * 'LowercaseLetter' +-- * 'TitlecaseLetter' +-- * 'ModifierLetter' +-- * 'OtherLetter' +-- +-- These classes are defined in the +-- , +-- part of the Unicode standard. The same document defines what is +-- and is not a \"Letter\". isAlpha :: Char -> Bool isAlpha c = case generalCategory c of UppercaseLetter -> True @@ -316,7 +341,20 @@ isAlpha c = case generalCategory c of -- Note that numeric digits outside the ASCII range, as well as numeric -- characters which aren't digits, are selected by this function but not by -- 'isDigit'. Such characters may be part of identifiers but are not used by --- the printer and reader to represent numbers. +-- the printer and reader to represent numbers, e.g., Roman numerals like @'V'@, +-- full-width digits like @'１'@ (aka @'\65297'@). +-- +-- This function returns 'True' if its argument has one of the +-- following 'GeneralCategory's, or 'False' otherwise: +-- +-- * 'UppercaseLetter' +-- * 'LowercaseLetter' +-- * 'TitlecaseLetter' +-- * 'ModifierLetter' +-- * 'OtherLetter' +-- * 'DecimalNumber' +-- * 'LetterNumber' +-- * 'OtherNumber' isAlphaNum :: Char -> Bool isAlphaNum c = case generalCategory c of UppercaseLetter -> True View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fae472a94a9fccf7a29aaad1b90c003265231a1e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fae472a94a9fccf7a29aaad1b90c003265231a1e 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 Dec 8 10:51:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 05:51:01 -0500 Subject: [Git][ghc/ghc][master] Fix float parsing in GHC Cmm Lexer Message-ID: <6572f5153d1db_3478bc574c73c126579@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 4 changed files: - compiler/GHC/Cmm/Lexer.x - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T Changes: ===================================== compiler/GHC/Cmm/Lexer.x ===================================== @@ -62,7 +62,7 @@ $namechar = [$namebegin $digit] @hexadecimal = $hexit+ @exponent = [eE] [\-\+]? @decimal - at floating_point = @decimal \. @decimal @exponent? | @decimal @exponent + at floating_point = [\-]? (@decimal \. @decimal @exponent? | @decimal @exponent) @escape = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) @strchar = ($printable # [\"\\]) | @escape ===================================== testsuite/tests/cmm/should_compile/T24224.cmm ===================================== @@ -0,0 +1,3 @@ +main () { + float64 f1; f1 = (-1.0 :: float64); +} ===================================== testsuite/tests/cmm/should_compile/T24224.stderr ===================================== @@ -0,0 +1,14 @@ + +==================== Output Cmm ==================== +[main() { // [] + { info_tbls: [] + stack_info: arg_space: 8 + } + {offset + _lbl_: + __locVar_::F64 = -1.0 :: W64; + goto c2; + } + }] + + ===================================== testsuite/tests/cmm/should_compile/all.T ===================================== @@ -12,3 +12,4 @@ test('T16930', normal, makefile_test, ['T16930']) test('T17442', normal, compile, ['']) test('T20725', normal, compile, ['-package ghc']) test('T23610', normal, makefile_test, ['T23610']) +test('T24224', [cmm_src, grep_errmsg(r'(F64.*);', [1])], compile, ['-no-hs-main -ddump-cmm -dsuppress-all -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca7510e4477fc37749a79dd6f77019684abbf140 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca7510e4477fc37749a79dd6f77019684abbf140 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 Dec 8 11:58:58 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 08 Dec 2023 06:58:58 -0500 Subject: [Git][ghc/ghc][wip/spj-unf-size] More adjustments Message-ID: <657305024e269_3478bc7d396ac14660@gitlab.mail> Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC Commits: 57023cff by Simon Peyton Jones at 2023-12-08T11:58:13+00:00 More adjustments * Revert un-force jumpSize change * Try making lambdas free - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -823,9 +823,9 @@ vanillaCallSize n_val_args voids = 10 * (1 + n_val_args - voids) -- | The size of a jump to a join point jumpSize :: Int -> Int -> Size -jumpSize n_val_args voids = 10 * (n_val_args - voids) - -- Not so much smaller than an ordinary call; - -- Trying the effect of not charging for the function head itself +jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) + -- A jump isn't so much smaller than a function call, but it's definitely + -- a known, exactly saturated call, so we make it very cheap -- A jump is 20% the size of a function call. Making jumps free reopens -- bug #6048, but making them any more expensive loses a 21% improvement in -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a @@ -875,9 +875,12 @@ funSize opts (avs,_) fun n_val_args voids lamSize :: UnfoldingOpts -> ExprTree -- Does not include the size of the body, just the lambda itself +lamSize _ = etZero -- Lambdas themselves cost nothing +{- lamSize opts = ExprTree { et_size = 10, et_wc_tot = 10 , et_cases = emptyBag , et_ret = unfoldingFunAppDiscount opts } +-} conSize :: DataCon -> Int -> ExprTree -- Does not need to include the size of the arguments themselves View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57023cffea75df13cbccb0f74596a2a9a8de7883 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57023cffea75df13cbccb0f74596a2a9a8de7883 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 Dec 8 12:07:08 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Fri, 08 Dec 2023 07:07:08 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Moving EpAnn out of extension points Message-ID: <657306ec96563_3478bc87f53d4147793@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: b0429b24 by Alan Zimmerman at 2023-12-08T12:03:12+00:00 EPA: Moving EpAnn out of extension points A lot done, more to do still. I am making ' versions of helper functions, when the work is complete the originals will disappear and the ' will go. Dump.hs needed to be able to properly blank out `[AddEpAnn]`, they used to be wrapped in an `EpAnn` which was easy to blank. - - - - - 26 changed files: - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/ThToHs.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -102,13 +102,25 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 bytestring = text . normalize_newlines . show list [] = brackets empty - list [x] = brackets (showAstData' x) - list (x1 : x2 : xs) = (text "[" <> showAstData' x1) - $$ go x2 xs + list [x] = hideOr x (brackets (showAstData' x)) + list (x1 : x2 : xs) = hideOr x1 + ((text "[" <> showAstData' x1) + $$ go x2 xs) where go y [] = text "," <> showAstData' y <> text "]" go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys + hideOr :: forall a .(Data a, Typeable a) => a -> SDoc -> SDoc + hideOr x f = if hide x + then text "blanked:[AddEpAnn]" + else f + + hide :: forall a .(Data a, Typeable a) => a -> Bool + hide x = ba == BlankEpAnnotations && isAddEpAnn x + + isAddEpAnn :: forall a .(Data a, Typeable a) => a -> Bool + isAddEpAnn x = (showConstr (toConstr x)) == "AddEpAnn" + -- Eliminate word-size dependence lit :: HsLit GhcPs -> SDoc lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -240,8 +240,8 @@ type instance XIPVar GhcRn = NoExtField type instance XIPVar GhcTc = DataConCantHappen type instance XOverLitE (GhcPass _) = NoExtField type instance XLitE (GhcPass _) = NoExtField -type instance XLam (GhcPass _) = EpAnn [AddEpAnn] -type instance XApp (GhcPass _) = EpAnnCO +type instance XLam (GhcPass _) = [AddEpAnn] +type instance XApp (GhcPass _) = NoExtField type instance XAppTypeE GhcPs = EpToken "@" type instance XAppTypeE GhcRn = NoExtField @@ -249,21 +249,21 @@ type instance XAppTypeE GhcTc = Type -- OpApp not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XOpApp GhcPs = EpAnn [AddEpAnn] +type instance XOpApp GhcPs = [AddEpAnn] type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = DataConCantHappen -- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XSectionL GhcPs = EpAnnCO -type instance XSectionR GhcPs = EpAnnCO -type instance XSectionL GhcRn = EpAnnCO -type instance XSectionR GhcRn = EpAnnCO +type instance XSectionL GhcPs = NoExtField +type instance XSectionR GhcPs = NoExtField +type instance XSectionL GhcRn = NoExtField +type instance XSectionR GhcRn = NoExtField type instance XSectionL GhcTc = DataConCantHappen type instance XSectionR GhcTc = DataConCantHappen -type instance XNegApp GhcPs = EpAnn [AddEpAnn] +type instance XNegApp GhcPs = [AddEpAnn] type instance XNegApp GhcRn = NoExtField type instance XNegApp GhcTc = NoExtField @@ -275,19 +275,19 @@ type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField type instance XExplicitTuple GhcTc = NoExtField -type instance XExplicitSum GhcPs = EpAnn AnnExplicitSum +type instance XExplicitSum GhcPs = AnnExplicitSum type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] -type instance XCase GhcPs = EpAnn EpAnnHsCase +type instance XCase GhcPs = EpAnnHsCase type instance XCase GhcRn = HsMatchContext GhcTc type instance XCase GhcTc = HsMatchContext GhcTc -type instance XIf GhcPs = EpAnn AnnsIf +type instance XIf GhcPs = AnnsIf type instance XIf GhcRn = NoExtField type instance XIf GhcTc = NoExtField -type instance XMultiIf GhcPs = EpAnn [AddEpAnn] +type instance XMultiIf GhcPs = [AddEpAnn] type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type @@ -295,7 +295,7 @@ type instance XLet GhcPs = (EpToken "let", EpToken "in") type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = EpAnn AnnList +type instance XDo GhcPs = AnnList type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type @@ -1123,7 +1123,7 @@ type instance XCmdArrApp GhcPs = EpAnn AddEpAnn type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = EpAnn AnnList +type instance XCmdArrForm GhcPs = AnnList type instance XCmdArrForm GhcRn = NoExtField type instance XCmdArrForm GhcTc = NoExtField ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -369,18 +369,18 @@ type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] -type instance XBangTy (GhcPass _) = EpAnn [AddEpAnn] +type instance XDocTy (GhcPass _) = [AddEpAnn] +type instance XBangTy (GhcPass _) = [AddEpAnn] type instance XRecTy GhcPs = EpAnn AnnList type instance XRecTy GhcRn = NoExtField type instance XRecTy GhcTc = NoExtField -type instance XExplicitListTy GhcPs = EpAnn [AddEpAnn] +type instance XExplicitListTy GhcPs = [AddEpAnn] type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn] +type instance XExplicitTupleTy GhcPs = [AddEpAnn] type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -239,14 +239,14 @@ mkLocatedList ms = case nonEmpty ms of Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noComments e1 e2) +mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2) mkHsAppWith :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) mkHsApps :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) @@ -331,11 +331,11 @@ mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs mkHsDo :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> AnnList -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> EpAnn AnnList + -> AnnList -> HsExpr GhcPs mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] @@ -396,7 +396,7 @@ mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [la loc = noAnnSrcSpan $ getHasLocList (last_stmt:stmts) -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b @@ -526,7 +526,7 @@ nlLitPat :: HsLit GhcPs -> LPat GhcPs nlLitPat l = noLocA (LitPat noExtField l) nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x)) +nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x)) nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc @@ -541,7 +541,7 @@ nlHsVarApps :: IsSrcSpanAnn p a nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f)) (map ((HsVar noExtField) . noLocA) xs)) where - mk f a = HsApp noComments (noLocA f) (noLocA a) + mk f a = HsApp noExtField (noLocA f) (noLocA a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) ===================================== compiler/GHC/HsToCore/Arrows.hs ===================================== @@ -784,9 +784,9 @@ dsCases ids local_vars stack_id stack_ty res_ty let left_id = mkConLikeTc (RealDataCon left_con) right_id = mkConLikeTc (RealDataCon right_con) - left_expr ty1 ty2 e = noLocA $ HsApp noComments + left_expr ty1 ty2 e = noLocA $ HsApp noExtField (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLocA $ HsApp noComments + right_expr ty1 ty2 e = noLocA $ HsApp noExtField (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, ===================================== compiler/GHC/Parser.y ===================================== @@ -2266,8 +2266,8 @@ atype :: { LHsType GhcPs } ; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer - | PREFIX_TILDE atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glEE $1 $>) [mj AnnTilde $1] cs) SrcLazy $2)) } - | PREFIX_BANG atype {% acsA (\cs -> sLL $1 $> (mkBangTy (EpAnn (glEE $1 $>) [mj AnnBang $1] cs) SrcStrict $2)) } + | PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnTilde $1] SrcLazy $2)) } + | PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnBang $1] SrcStrict $2)) } | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glEE $1 $>) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2)) ; checkRecordSyntax decls }} @@ -2288,8 +2288,8 @@ atype :: { LHsType GhcPs } | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } | SIMPLEQUOTE '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $3 (gl $4) - ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }} - | SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) } + ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $6] (h : $5)) }} + | SIMPLEQUOTE '[' comma_types0 ']' {% amsA' (sLL $1 $> $ HsExplicitListTy [mj AnnSimpleQuote $1,mos $2,mcs $4] IsPromoted $3) } | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -2297,7 +2297,7 @@ atype :: { LHsType GhcPs } -- (One means a list type, zero means the list type constructor, -- so you have to quote those.) | '[' ktype ',' comma_types1 ']' {% do { h <- addTrailingCommaA $2 (gl $3) - ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glEE $1 $>) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }} + ; amsA' (sLL $1 $> $ HsExplicitListTy [mos $1,mcs $5] NotPromoted (h:$4)) }} | INTEGER { sLLa $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) (il_value (getINTEGER $1)) } | CHAR { sLLa $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1) @@ -2902,7 +2902,7 @@ aexp :: { ECP } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glEE $1 $>) (mj AnnIf $1:(fst $ unLoc $2)) cs) + amsA' (sLL $1 $> $ HsMultiIf (mj AnnIf $1:(fst $ unLoc $2)) (reverse $ snd $ unLoc $2)) } | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> return $ ECP $ @@ -2920,11 +2920,11 @@ aexp :: { ECP } (AnnList (Just $ glR $2) Nothing Nothing [mj AnnDo $1] []) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ - acsA (\cs -> L (comb2 $1 $2) + amsA' (L (comb2 $1 $2) (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) $2 - (EpAnn (glEE $1 $>) (AnnList (Just $ glR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) } + (AnnList (Just $ glR $2) Nothing Nothing [mj AnnMdo $1] []) )) } | 'proc' aexp '->' exp {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4 at cmd -> @@ -3028,7 +3028,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glEE $1 $>) (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) $2 Prefix Nothing (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3096,12 +3096,12 @@ texp :: { ECP } runPV (rejectPragmaPV $1) >> runPV $2 >>= \ $2 -> return $ ecpFromExp $ - sLLa $1 $> $ SectionL noAnn $1 (n2l $2) } + sLLa $1 $> $ SectionL noExtField $1 (n2l $2) } | qopm infixexp { ECP $ superInfixOp $ unECP $2 >>= \ $2 -> $1 >>= \ $1 -> - pvA $ mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 } + pvA' $ mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 } -- View patterns get parenthesized above | exp '->' texp { ECP $ @@ -3185,7 +3185,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (Locate { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2) - ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs)) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (Just ao) (Just ac) [] [])) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -4360,6 +4360,11 @@ ams1 (L l a) b = do cs <- getCommentsFor (locA l) return (L (EpAnn (spanAsAnchor l) noAnn cs) b) +amsA' :: MonadP m => Located a -> m (LocatedA a) +amsA' (L l a) = do + cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) a) + amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) amsA (L l a) bs = do cs <- getCommentsFor (locA l) @@ -4415,6 +4420,10 @@ pvA :: (MonadP m, NoAnn t) => m (Located a) -> m (LocatedAn t a) pvA a = do { av <- a ; return (reLoc av) } +pvA' :: (MonadP m, NoAnn t) => m (LocatedAn t a) -> m (LocatedAn t a) +pvA' a = do { av <- a + ; return av } + pvN :: MonadP m => m (LocatedN a) -> m (LocatedN a) pvN a = do { (L l av) <- a ; return (L l av) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1445,7 +1445,7 @@ isFunLhs e = go e [] [] [] _ -> return Nothing } go _ _ _ _ = return Nothing -mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy :: [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs mkBangTy anns strictness = HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness) @@ -1457,9 +1457,7 @@ data UnpackednessPragma = addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do let l' = combineSrcSpans lprag (getLocA ty) - cs <- getCommentsFor l' - let an = EpAnn (spanAsAnchor l') anns cs - t' = addUnpackedness an ty + let t' = addUnpackedness anns ty return (L (noAnnSrcSpan l') t') where -- If we have a HsBangTy that only has a strictness annotation, @@ -1468,7 +1466,7 @@ addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do -- Otherwise, wrap the type in a new HsBangTy constructor. addUnpackedness an (L _ (HsBangTy x bang t)) | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang - = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t + = HsBangTy (an Semi.<> x) (HsSrcBang prag unpk strictness) t addUnpackedness an t = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t @@ -1632,7 +1630,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "(# a)" (right operator section) mkHsSectionR_PV - :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b) + :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b) -- | Disambiguate "(a -> b)" (view pattern) mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) @@ -1717,7 +1715,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsOpAppPV l c1 op c2 = do let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2] + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2] mkHsCasePV l c (L lm m) anns = do cs <- getCommentsFor l @@ -1797,33 +1795,33 @@ instance DisambECP (HsExpr GhcPs) where superInfixOp m = m mkHsOpAppPV l e1 op e2 = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLoc op) e2 + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp [] e1 (reLoc op) e2 mkHsCasePV l e (L lm m) anns = do cs <- getCommentsFor l let mg = mkMatchGroup FromSource (L lm m) - return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg) mkHsLamPV l lam_variant (L lm m) anns = do cs <- getCommentsFor l let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) checkLamMatchGroup l lam_variant mg - return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) lam_variant mg) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg) type FunArg (HsExpr GhcPs) = HsExpr GhcPs superFunArg m = m - mkHsAppPV l e1 e2 = do + mkHsAppPV l@(EpAnn anc an csIn) e1 e2 = do cs <- getCommentsFor (locA l) checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (HsApp noExtField e1 e2) mkHsAppTypePV l e at t = do checkExpBlockArguments e return $ L l (HsAppType at e (mkHsWildCardBndrs t)) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs)) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) mkHsDoPV l mod stmts anns = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo anns (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -1852,10 +1850,10 @@ instance DisambECP (HsExpr GhcPs) where checkRecordSyntax (L (noAnnSrcSpan l) r) mkHsNegAppPV l a anns = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr) mkHsSectionR_PV l op e = do cs <- getCommentsFor l - return $ L l (SectionR (comment (realSrcSpan l) cs) op e) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e) mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) @@ -3145,13 +3143,13 @@ mkSumOrTupleExpr l boxity (Tuple es) anns = do -- Sum -- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = -- return $ L l (ExplicitSum noExtField alt arity e) -mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do +mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) anns = do let an = case anns of [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] -> AnnExplicitSum o barsp barsa c _ -> panic "mkSumOrTupleExpr" cs <- getCommentsFor (locA l) - return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) + return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e) mkSumOrTupleExpr l Boxed a at Sum{} _ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -316,7 +316,7 @@ rnExpr (HsOverLit x lit) ; case mb_neg of Nothing -> return (HsOverLit x lit', fvs) Just neg -> - return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit')) + return (HsApp noExtField (noLocA neg) (noLocA (HsOverLit x lit')) , fvs ) } rnExpr (HsApp x fun arg) @@ -639,9 +639,9 @@ rnSection section@(SectionL x expr op) -- Note [Left and right sections] ; let rn_section = SectionL x expr' op' ds_section - | postfix_ops = HsApp noAnn op' expr' + | postfix_ops = HsApp noExtField op' expr' | otherwise = genHsApps leftSectionName - [wrapGenSpan $ HsApp noAnn op' expr'] + [wrapGenSpan $ HsApp noExtField op' expr'] ; return ( mkExpandedExpr rn_section ds_section , fvs_op `plusFV` fvs_expr) } @@ -2186,7 +2186,7 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do -- Need 'pureAName' and not 'returnMName' here, so that it requires -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed). (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName - let expr = HsApp noComments (noLocA ret) tup + let expr = HsApp noExtField (noLocA ret) tup return (expr, emptyFVs) return ( ApplicativeArgMany { xarg_app_arg_many = noExtField ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -389,8 +389,8 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter (L q_span' quote) - = L q_span $ HsApp noComments (L q_span - $ HsApp noComments (L q_span + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L (l2l q_span) quote_selector))) quoterExpr) quoteExpr ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -728,7 +728,7 @@ genHsApps' (L _ fun) [] = genHsVar fun genHsApps' (L loc fun) (arg:args) = foldl genHsApp (unLoc $ mkHsApp (L (l2l loc) $ genHsVar fun) arg) args genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg +genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn genLHsApp fun arg = wrapGenSpan (genHsApp fun arg) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -463,7 +463,7 @@ tcExpr (HsStatic fvs expr) res_ty ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] ; loc <- getSrcSpanM ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName - ; return $ mkHsWrapCo co $ HsApp noComments + ; return $ mkHsWrapCo co $ HsApp noExtField (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) } ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -381,7 +381,7 @@ rebuild_hs_apps fun _ [] = fun rebuild_hs_apps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } - -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args + -> rebuild_hs_apps (HsApp noExtField lfun arg) ctxt' args ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } -> rebuild_hs_apps (HsAppType ty lfun hs_ty) ctxt' args EPrag ctxt' p @@ -1087,7 +1087,7 @@ tcInferOverLit lit@(OverLit { ol_val = val HsLit noExtField hs_lit from_expr = mkHsWrap (wrap2 <.> wrap1) $ HsVar noExtField (L loc from_id) - witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr + witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable , ol_witness = witness , ol_type = res_ty } } ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1002,7 +1002,7 @@ runAnnotation target expr = do ; let specialised_to_annotation_wrapper_expr = L loc' (mkHsWrap wrapper (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) - ; return (L loc' (HsApp noComments + ; return (L loc' (HsApp noExtField specialised_to_annotation_wrapper_expr expr')) }) ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1332,7 +1332,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noComments (L loc' fun) + app_to_meth fun meth_id = HsApp noExtField (L loc' fun) (L loc' (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars @@ -1869,7 +1869,7 @@ tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys where inst_loc' = noAnnSrcSpan inst_loc error_rhs dflags = L inst_loc' - $ HsApp noComments error_fun (error_msg dflags) + $ HsApp noExtField error_fun (error_msg dflags) error_fun = L inst_loc' $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -1061,7 +1061,7 @@ tcPatToExpr args pat = go pat Nothing -> notInvertible p Just inverse -> fmap - (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr)) + (\ expr -> HsApp noExtField (wrapGenSpan inverse) (wrapGenSpan expr)) (go1 (unLoc pat)) -- The following patterns are not invertible. ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -2393,7 +2393,7 @@ shortCutLit platform val res_ty | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1043,7 +1043,7 @@ cvtl e = wrapLA (cvt e) if is_compound_lit l' then wrapParLA gHsPar e' else pure e' cvt (AppE e1 e2) = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1 ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2 - ; return $ HsApp noComments e1' e2' } + ; return $ HsApp noExtField e1' e2' } cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e ; t' <- parenthesizeHsType appPrec <$> cvtType t ; return $ HsAppType noAnn e' @@ -1112,12 +1112,12 @@ cvtl e = wrapLA (cvt e) cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ do { s' <- cvtl s; y' <- cvtl y ; wrapParLA gHsPar $ - SectionR noComments s' y' } + SectionR noExtField s' y' } -- See Note [Sections in HsSyn] in GHC.Hs.Expr cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ do { x' <- cvtl x; s' <- cvtl s ; wrapParLA gHsPar $ - SectionL noComments x' s' } + SectionL noExtField x' s' } cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ do { s' <- cvtl s ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -175,11 +175,7 @@ (EpaComments [])) (HsDocTy - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { T17544.hs:6:14-16 }) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -577,13 +577,9 @@ (EpaComments [])) (HsExplicitListTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:12:10-12 }) - [(AddEpAnn AnnSimpleQuote (EpaSpan { DumpParsedAst.hs:12:10 })) - ,(AddEpAnn AnnOpenS (EpaSpan { DumpParsedAst.hs:12:11 })) - ,(AddEpAnn AnnCloseS (EpaSpan { DumpParsedAst.hs:12:12 }))] - (EpaComments - [])) + [(AddEpAnn AnnSimpleQuote (EpaSpan { DumpParsedAst.hs:12:10 })) + ,(AddEpAnn AnnOpenS (EpaSpan { DumpParsedAst.hs:12:11 })) + ,(AddEpAnn AnnCloseS (EpaSpan { DumpParsedAst.hs:12:12 }))] (IsPromoted) [])))] (Prefix) @@ -2377,11 +2373,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaSpan { DumpParsedAst.hs:25:8-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAst.hs:25:8-15 }) ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -258,25 +258,21 @@ (AnnListItem []) (EpaComments - [])) + [(L + (EpaSpan + { DumpParsedAstComments.hs:15:3-19 }) + (EpaComment + (EpaLineComment + "-- normal comment") + { DumpParsedAstComments.hs:14:7-8 }))])) (HsDo - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:(14,7)-(16,3) }) - (AnnList - (Just - (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:14:7-8 }))] - []) - (EpaComments - [(L - (EpaSpan - { DumpParsedAstComments.hs:15:3-19 }) - (EpaComment - (EpaLineComment - "-- normal comment") - { DumpParsedAstComments.hs:14:7-8 }))])) + (AnnList + (Just + (EpaSpan { DumpParsedAstComments.hs:16:3 })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { DumpParsedAstComments.hs:14:7-8 }))] + []) (DoExpr (Nothing)) (L @@ -411,11 +407,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:19:8-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpParsedAstComments.hs:19:8-15 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -92,11 +92,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaSpan { DumpRenamedAst.hs:35:8-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:35:8-15 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -320,17 +320,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { DumpSemis.hs:(10,7)-(12,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:10:7-8 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:10:7-8 }))] + []) (DoExpr (Nothing)) (L @@ -362,17 +358,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { DumpSemis.hs:11:3-15 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:11:6-15 })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:11:3-4 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { DumpSemis.hs:11:6-15 })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:11:3-4 }))] + []) (DoExpr (Nothing)) (L @@ -635,17 +627,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { DumpSemis.hs:(15,7)-(19,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:15:7-8 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:15:7-8 }))] + []) (DoExpr (Nothing)) (L @@ -901,17 +889,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { DumpSemis.hs:22:7-30 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:22:10-30 })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:22:7-8 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { DumpSemis.hs:22:10-30 })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { DumpSemis.hs:22:7-8 }))] + []) (DoExpr (Nothing)) (L @@ -2296,14 +2280,10 @@ (EpaComments [])) (HsCase - (EpAnn - (EpaSpan { DumpSemis.hs:(37,3)-(44,4) }) - (EpAnnHsCase - (EpaSpan { DumpSemis.hs:37:3-6 }) - (EpaSpan { DumpSemis.hs:37:10-11 }) - []) - (EpaComments - [])) + (EpAnnHsCase + (EpaSpan { DumpSemis.hs:37:3-6 }) + (EpaSpan { DumpSemis.hs:37:10-11 }) + []) (L (EpAnn (EpaSpan { DumpSemis.hs:37:8 }) ===================================== testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr ===================================== @@ -20,11 +20,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -33,11 +29,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -46,11 +38,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -59,11 +47,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -72,11 +56,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -85,11 +65,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -156,11 +132,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -230,11 +202,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -243,11 +211,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -256,11 +220,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -269,11 +229,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -282,11 +238,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -295,11 +247,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -366,11 +314,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -440,11 +384,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -453,11 +393,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -466,11 +402,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -479,11 +411,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -492,11 +420,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -505,11 +429,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -576,11 +496,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -650,11 +566,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -663,11 +575,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -676,11 +584,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -689,11 +593,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -702,11 +602,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -715,11 +611,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -786,11 +678,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -860,11 +748,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -873,11 +757,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -886,11 +766,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -899,11 +775,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -912,11 +784,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -925,11 +793,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -996,11 +860,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1070,11 +930,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1120,11 +976,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1170,11 +1022,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1220,11 +1068,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1233,11 +1077,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1302,11 +1142,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1315,11 +1151,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1384,11 +1216,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1397,11 +1225,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1466,11 +1290,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1479,11 +1299,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1548,11 +1364,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1561,11 +1373,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1630,11 +1438,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1643,11 +1447,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1694,11 +1494,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1707,11 +1503,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1765,11 +1557,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1778,11 +1566,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1836,11 +1620,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1849,11 +1629,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1927,11 +1703,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -1940,11 +1712,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -2011,11 +1779,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -2024,11 +1788,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -2058,11 +1818,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -2104,11 +1860,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { }) @@ -2242,11 +1994,7 @@ (EpaComments [])) (HsApp - (EpAnn - (EpaDelta (SameLine 0) []) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpTypecheckedAst.hs:20:8-15 }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -1231,13 +1231,9 @@ (EpaComments [])) (HsExplicitListTy - (EpAnn - (EpaSpan { KindSigs.hs:26:13-29 }) - [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:26:13 })) - ,(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:26:14 })) - ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:26:29 }))] - (EpaComments - [])) + [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:26:13 })) + ,(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:26:14 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:26:29 }))] (IsPromoted) [(L (EpAnn @@ -1335,12 +1331,8 @@ (EpaComments [])) (HsExplicitListTy - (EpAnn - (EpaSpan { KindSigs.hs:27:14-45 }) - [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:27:14 })) - ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:27:45 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:27:14 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:27:45 }))] (NotPromoted) [(L (EpAnn @@ -1521,13 +1513,9 @@ (EpaComments [])) (HsExplicitTupleTy - (EpAnn - (EpaSpan { KindSigs.hs:28:16-44 }) - [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:28:16 })) - ,(AddEpAnn AnnOpenP (EpaSpan { KindSigs.hs:28:17 })) - ,(AddEpAnn AnnCloseP (EpaSpan { KindSigs.hs:28:44 }))] - (EpaComments - [])) + [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:28:16 })) + ,(AddEpAnn AnnOpenP (EpaSpan { KindSigs.hs:28:17 })) + ,(AddEpAnn AnnCloseP (EpaSpan { KindSigs.hs:28:44 }))] [(L (EpAnn (EpaSpan { KindSigs.hs:28:19-39 }) @@ -1550,12 +1538,8 @@ (EpaComments [])) (HsExplicitListTy - (EpAnn - (EpaSpan { KindSigs.hs:28:19-29 }) - [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:28:19 })) - ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:28:29 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:28:19 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:28:29 }))] (NotPromoted) [(L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -362,17 +362,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { Test20297.hs:11:19-26 }) - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { Test20297.hs:11:19-20 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { Test20297.hs:11:19-20 }))] + []) (DoExpr (Nothing)) (L @@ -767,17 +763,13 @@ (EpaComments [])) (HsDo - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:17-24 }) - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (Nothing) - (Nothing) - [(AddEpAnn AnnDo (EpaSpan { Test20297.ppr.hs:9:17-18 }))] - []) - (EpaComments - [])) + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (Nothing) + (Nothing) + [(AddEpAnn AnnDo (EpaSpan { Test20297.ppr.hs:9:17-18 }))] + []) (DoExpr (Nothing)) (L ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -748,6 +748,14 @@ markLensMAA (EpAnn anc a cs) l = aa' <- markAddEpAnn aa return (EpAnn anc (set l (Just aa') a) cs) +markLensMAA' :: (Monad m, Monoid w) => a -> Lens a (Maybe AddEpAnn) -> EP w m a +markLensMAA' a l = + case view l a of + Nothing -> return a + Just aa -> do + aa' <- markAddEpAnn aa + return (set l (Just aa') a) + markLensAA :: (Monad m, Monoid w) => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) markLensAA (EpAnn anc a cs) l = do a' <- markKw (view l a) @@ -768,6 +776,34 @@ markEpAnnLMS (EpAnn anc a cs) l kw (Just str) = do return (AddEpAnn kw' r') | otherwise = return (AddEpAnn kw' r) +markEpAnnLMS'' :: (Monad m, Monoid w) + => a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m a +markEpAnnLMS'' an l kw Nothing = markEpAnnL' an l kw +markEpAnnLMS'' a l kw (Just str) = do + anns <- mapM go (view l a) + return (set l anns a) + where + go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn + go (AddEpAnn kw' r) + | kw' == kw = do + r' <- printStringAtAA r str + return (AddEpAnn kw' r') + | otherwise = return (AddEpAnn kw' r) + + +markEpAnnMS' :: (Monad m, Monoid w) + => [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m [AddEpAnn] +markEpAnnMS' anns kw Nothing = mark' anns kw +markEpAnnMS' anns kw (Just str) = do + mapM go anns + where + go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn + go (AddEpAnn kw' r) + | kw' == kw = do + r' <- printStringAtAA r str + return (AddEpAnn kw' r') + | otherwise = return (AddEpAnn kw' r) + markEpAnnLMS' :: (Monad m, Monoid w) => EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) markEpAnnLMS' an l _kw Nothing = markLensKwA an l @@ -1263,6 +1299,13 @@ markLensKw (EpAnn anc a cs) l kw = do loc <- markKwA kw (view l a) return (EpAnn anc (set l loc a) cs) +markLensKw' :: (Monad m, Monoid w) + => a -> Lens a EpaLocation -> AnnKeywordId -> EP w m a +markLensKw' a l kw = do + loc <- markKwA kw (view l a) + return (set l loc a) + +-- TODO: delete this in favour of markLensKw markAnnKwL :: (Monad m, Monoid w) => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) markAnnKwL = markLensKw @@ -1273,6 +1316,12 @@ markAnnKwAllL (EpAnn anc a cs) l kw = do anns <- mapM (markKwA kw) (view l a) return (EpAnn anc (set l anns a) cs) +markAnnKwAllL' :: (Monad m, Monoid w) + => a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m a +markAnnKwAllL' a l kw = do + anns <- mapM (markKwA kw) (view l a) + return (set l anns a) + markLensKwM :: (Monad m, Monoid w) => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) markLensKwM (EpAnn anc a cs) l kw = do @@ -1282,6 +1331,15 @@ markLensKwM (EpAnn anc a cs) l kw = do go Nothing = return Nothing go (Just s) = Just <$> markKwA kw s +markLensKwM' :: (Monad m, Monoid w) + => a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m a +markLensKwM' a l kw = do + new <- go (view l a) + return (set l new a) + where + go Nothing = return Nothing + go (Just s) = Just <$> markKwA kw s + -- --------------------------------------------------------------------- markEpAnnL :: (Monad m, Monoid w) @@ -1290,6 +1348,12 @@ markEpAnnL (EpAnn anc a cs) l kw = do anns <- mark' (view l a) kw return (EpAnn anc (set l anns a) cs) +markEpAnnL' :: (Monad m, Monoid w) + => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann +markEpAnnL' a l kw = do + anns <- mark' (view l a) kw + return (set l anns a) + markEpAnnAllL :: (Monad m, Monoid w) => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) markEpAnnAllL (EpAnn anc a cs) l kw = do @@ -1301,6 +1365,17 @@ markEpAnnAllL (EpAnn anc a cs) l kw = do then markKw an else return an +markEpAnnAllL' :: (Monad m, Monoid w) + => ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m ann +markEpAnnAllL' a l kw = do + anns <- mapM doit (view l a) + return (set l anns a) + where + doit an@(AddEpAnn ka _) + = if ka == kw + then markKw an + else return an + markAddEpAnn :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn markAddEpAnn a@(AddEpAnn kw _) = do r <- mark' [a] kw @@ -1375,6 +1450,17 @@ markAnnListA an action = do an3 <- markLensMAA an2 lal_close return (an3, r) +markAnnListA' :: (Monad m, Monoid w) + => AnnList + -> (AnnList -> EP w m (AnnList, a)) + -> EP w m (AnnList, a) +markAnnListA' an action = do + an0 <- markLensMAA' an lal_open + an1 <- markEpAnnAllL' an0 lal_rest AnnSemi + (an2, r) <- action an1 + an3 <- markLensMAA' an2 lal_close + return (an3, r) + -- --------------------------------------------------------------------- printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () @@ -2864,21 +2950,21 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsIPVar{}) = NoEntryVal getAnnotationEntry (HsOverLit{}) = NoEntryVal getAnnotationEntry (HsLit{}) = NoEntryVal - getAnnotationEntry (HsLam an _ _) = fromAnn an - getAnnotationEntry (HsApp an _ _) = fromAnn an + getAnnotationEntry (HsLam{}) = NoEntryVal + getAnnotationEntry (HsApp{}) = NoEntryVal getAnnotationEntry (HsAppType _ _ _) = NoEntryVal - getAnnotationEntry (OpApp an _ _ _) = fromAnn an - getAnnotationEntry (NegApp an _ _) = fromAnn an + getAnnotationEntry (OpApp _ _ _ _) = NoEntryVal + getAnnotationEntry (NegApp _ _ _) = NoEntryVal getAnnotationEntry (HsPar{}) = NoEntryVal - getAnnotationEntry (SectionL an _ _) = fromAnn an - getAnnotationEntry (SectionR an _ _) = fromAnn an + getAnnotationEntry (SectionL _ _ _) = NoEntryVal + getAnnotationEntry (SectionR _ _ _) = NoEntryVal getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an - getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an - getAnnotationEntry (HsCase an _ _) = fromAnn an - getAnnotationEntry (HsIf an _ _ _) = fromAnn an - getAnnotationEntry (HsMultiIf an _) = fromAnn an + getAnnotationEntry (ExplicitSum _ _ _ _) = NoEntryVal + getAnnotationEntry (HsCase _ _ _) = NoEntryVal + getAnnotationEntry (HsIf _ _ _ _) = NoEntryVal + getAnnotationEntry (HsMultiIf _ _) = NoEntryVal getAnnotationEntry (HsLet _ _ _) = NoEntryVal - getAnnotationEntry (HsDo an _ _) = fromAnn an + getAnnotationEntry (HsDo _ _ _) = NoEntryVal getAnnotationEntry (ExplicitList an _) = fromAnn an getAnnotationEntry (RecordCon an _ _) = fromAnn an getAnnotationEntry (RecordUpd an _ _) = fromAnn an @@ -2902,21 +2988,21 @@ instance ExactPrint (HsExpr GhcPs) where setAnnotationAnchor a@(HsIPVar{}) _ _ _s = a setAnnotationAnchor a@(HsOverLit {}) _ _ _s = a setAnnotationAnchor a@(HsLit {}) _ _ _s = a - setAnnotationAnchor (HsLam an a b) anc ts cs = (HsLam (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsApp an a b) anc ts cs = (HsApp (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(HsLam{}) _ _ _s = a + setAnnotationAnchor a@(HsApp{}) _ _ _s = a setAnnotationAnchor a@(HsAppType {}) _ _ _s = a - setAnnotationAnchor (OpApp an a b c) anc ts cs = (OpApp (setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (NegApp an a b) anc ts cs = (NegApp (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(OpApp{}) _ _ _s = a + setAnnotationAnchor a@(NegApp{}) _ _ _s = a setAnnotationAnchor a@(HsPar {}) _ _ _s = a - setAnnotationAnchor (SectionL an a b) anc ts cs = (SectionL (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (SectionR an a b) anc ts cs = (SectionR (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(SectionL{}) _ _ _s = a + setAnnotationAnchor a@(SectionR{}) _ _ _s = a setAnnotationAnchor (ExplicitTuple an a b) anc ts cs = (ExplicitTuple (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (ExplicitSum an a b c) anc ts cs = (ExplicitSum (setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (HsCase an a b) anc ts cs = (HsCase (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsIf an a b c) anc ts cs = (HsIf (setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (HsMultiIf an a) anc ts cs = (HsMultiIf (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(HsLet{}) _ _ _s = a - setAnnotationAnchor (HsDo an a b) anc ts cs = (HsDo (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(ExplicitSum{}) _ _ _s = a + setAnnotationAnchor a@(HsCase{}) _ _ _s = a + setAnnotationAnchor a@(HsIf{}) _ _ _s = a + setAnnotationAnchor a@(HsMultiIf{}) _ _ _s = a + setAnnotationAnchor a@(HsLet{}) _ _ _s = a + setAnnotationAnchor a@(HsDo{}) _ _ _s = a setAnnotationAnchor (ExplicitList an a) anc ts cs = (ExplicitList (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (RecordCon an a b) anc ts cs = (RecordCon (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (RecordUpd an a b) anc ts cs = (RecordUpd (setAnchorEpa an anc ts cs) a b) @@ -2976,11 +3062,11 @@ instance ExactPrint (HsExpr GhcPs) where return (HsLit an lit') exact (HsLam an lam_variant mg) = do - an0 <- markEpAnnL an lidl AnnLam + an0 <- mark' an AnnLam an1 <- case lam_variant of LamSingle -> return an0 - LamCase -> markEpAnnL an0 lidl AnnCase - LamCases -> markEpAnnL an0 lidl AnnCases + LamCase -> mark' an0 AnnCase + LamCases -> mark' an0 AnnCases mg' <- markAnnotated mg return (HsLam an1 lam_variant mg') @@ -3002,7 +3088,7 @@ instance ExactPrint (HsExpr GhcPs) where return (OpApp an e1' e2' e3') exact (NegApp an e s) = do - an0 <- markEpAnnL an lidl AnnMinus + an0 <- markEpAnnL' an lidl AnnMinus e' <- markAnnotated e return (NegApp an0 e' s) @@ -3036,39 +3122,39 @@ instance ExactPrint (HsExpr GhcPs) where return (ExplicitTuple an1 args' b) exact (ExplicitSum an alt arity expr) = do - an0 <- markLensKw an laesOpen AnnOpenPH - an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar + an0 <- markLensKw' an laesOpen AnnOpenPH + an1 <- markAnnKwAllL' an0 laesBarsBefore AnnVbar expr' <- markAnnotated expr - an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar - an3 <- markLensKw an2 laesClose AnnClosePH + an2 <- markAnnKwAllL' an1 laesBarsAfter AnnVbar + an3 <- markLensKw' an2 laesClose AnnClosePH return (ExplicitSum an3 alt arity expr') exact (HsCase an e alts) = do - an0 <- markAnnKwL an lhsCaseAnnCase AnnCase + an0 <- markLensKw' an lhsCaseAnnCase AnnCase e' <- markAnnotated e - an1 <- markAnnKwL an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi + an1 <- markLensKw' an0 lhsCaseAnnOf AnnOf + an2 <- markEpAnnL' an1 lhsCaseAnnsRest AnnOpenC + an3 <- markEpAnnAllL' an2 lhsCaseAnnsRest AnnSemi alts' <- setLayoutBoth $ markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC + an4 <- markEpAnnL' an3 lhsCaseAnnsRest AnnCloseC return (HsCase an4 e' alts') exact (HsIf an e1 e2 e3) = do - an0 <- markAnnKwL an laiIf AnnIf + an0 <- markLensKw' an laiIf AnnIf e1' <- markAnnotated e1 - an1 <- markLensKwM an0 laiThenSemi AnnSemi - an2 <- markAnnKwL an1 laiThen AnnThen + an1 <- markLensKwM' an0 laiThenSemi AnnSemi + an2 <- markLensKw' an1 laiThen AnnThen e2' <- markAnnotated e2 - an3 <- markLensKwM an2 laiElseSemi AnnSemi - an4 <- markAnnKwL an3 laiElse AnnElse + an3 <- markLensKwM' an2 laiElseSemi AnnSemi + an4 <- markLensKw' an3 laiElse AnnElse e3' <- markAnnotated e3 return (HsIf an4 e1' e2' e3') exact (HsMultiIf an mg) = do - an0 <- markEpAnnL an lidl AnnIf - an1 <- markEpAnnL an0 lidl AnnOpenC -- optional + an0 <- markEpAnnL' an lidl AnnIf + an1 <- markEpAnnL' an0 lidl AnnOpenC -- optional mg' <- markAnnotated mg - an2 <- markEpAnnL an1 lidl AnnCloseC -- optional + an2 <- markEpAnnL' an1 lidl AnnCloseC -- optional return (HsMultiIf an2 mg') exact (HsLet (tkLet, tkIn) binds e) = do @@ -3081,7 +3167,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - (an',stmts') <- markAnnListA an $ \a -> exactDo a do_or_list_comp stmts + (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts return (HsDo an' do_or_list_comp stmts') exact (ExplicitList an es) = do @@ -3230,23 +3316,23 @@ instance ExactPrint (HsExpr GhcPs) where -- --------------------------------------------------------------------- exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => EpAnn AnnList -> HsDoFlavour -> LocatedAn an a - -> EP w m (EpAnn AnnList, LocatedAn an a) -exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts + => AnnList -> HsDoFlavour -> LocatedAn an a + -> EP w m (AnnList, LocatedAn an a) +exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an GhciStmtCtxt stmts = markEpAnnL' an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts exactDo an ListComp stmts = markMaybeDodgyStmts an stmts exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts exactMdo :: (Monad m, Monoid w) - => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) -exactMdo an Nothing kw = markEpAnnL an lal_rest kw -exactMdo an (Just module_name) kw = markEpAnnLMS an lal_rest kw (Just n) + => AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m AnnList +exactMdo an Nothing kw = markEpAnnL' an lal_rest kw +exactMdo an (Just module_name) kw = markEpAnnLMS'' an lal_rest kw (Just n) where n = (moduleNameString module_name) ++ "." ++ (keywordToString kw) markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => EpAnn AnnList -> LocatedAn an a -> EP w m (EpAnn AnnList, LocatedAn an a) + => AnnList -> LocatedAn an a -> EP w m (AnnList, LocatedAn an a) markMaybeDodgyStmts an stmts = if isGoodSrcSpan (getLocA stmts) then do @@ -3440,7 +3526,7 @@ instance ExactPrint (HsCmdTop GhcPs) where instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an + getAnnotationEntry (HsCmdArrForm _ _ _ _ _ ) = NoEntryVal getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an getAnnotationEntry (HsCmdPar _ _) = NoEntryVal getAnnotationEntry (HsCmdCase an _ _) = fromAnn an @@ -3450,7 +3536,7 @@ instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdDo an _) = fromAnn an setAnnotationAnchor (HsCmdArrApp an a b c d) anc ts cs = (HsCmdArrApp (setAnchorEpa an anc ts cs) a b c d) - setAnnotationAnchor (HsCmdArrForm an a b c d ) anc ts cs = (HsCmdArrForm (setAnchorEpa an anc ts cs) a b c d ) + setAnnotationAnchor a@(HsCmdArrForm{}) _ _ _s = a setAnnotationAnchor (HsCmdApp an a b ) anc ts cs = (HsCmdApp (setAnchorEpa an anc ts cs) a b ) setAnnotationAnchor (HsCmdLam an a b) anc ts cs = (HsCmdLam (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsCmdPar _ _) _ _ _s = a @@ -3475,7 +3561,7 @@ instance ExactPrint (HsCmd GhcPs) where return (HsCmdArrApp an1 arr' arg' o isRightToLeft) exact (HsCmdArrForm an e fixity mf cs) = do - an0 <- markLensMAA an lal_open + an0 <- markLensMAA' an lal_open (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 @@ -3487,7 +3573,7 @@ instance ExactPrint (HsCmd GhcPs) where cs' <- markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" - an1 <- markLensMAA an0 lal_close + an1 <- markLensMAA' an0 lal_close return (HsCmdArrForm an1 e' fixity mf cs') exact (HsCmdApp an e1 e2) = do @@ -4032,11 +4118,11 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsStarTy _ _) = NoEntryVal getAnnotationEntry (HsKindSig an _ _) = fromAnn an getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal - getAnnotationEntry (HsDocTy an _ _) = fromAnn an - getAnnotationEntry (HsBangTy an _ _) = fromAnn an + getAnnotationEntry (HsDocTy _ _ _) = NoEntryVal + getAnnotationEntry (HsBangTy _ _ _) = NoEntryVal getAnnotationEntry (HsRecTy an _) = fromAnn an - getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an - getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an + getAnnotationEntry (HsExplicitListTy _ _ _) = NoEntryVal + getAnnotationEntry (HsExplicitTupleTy _ _) = NoEntryVal getAnnotationEntry (HsTyLit _ _) = NoEntryVal getAnnotationEntry (HsWildCardTy _) = NoEntryVal getAnnotationEntry (XHsType _) = NoEntryVal @@ -4056,11 +4142,11 @@ instance ExactPrint (HsType GhcPs) where setAnnotationAnchor a@(HsStarTy _ _) _ _ _s = a setAnnotationAnchor (HsKindSig an a b) anc ts cs = (HsKindSig (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsSpliceTy _ _) _ _ _s = a - setAnnotationAnchor (HsDocTy an a b) anc ts cs = (HsDocTy (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsBangTy an a b) anc ts cs = (HsBangTy (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(HsDocTy{}) _ _ _s = a + setAnnotationAnchor a@(HsBangTy{}) _ _ _s = a setAnnotationAnchor (HsRecTy an a) anc ts cs = (HsRecTy (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsExplicitListTy an a b) anc ts cs = (HsExplicitListTy (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsExplicitTupleTy an a) anc ts cs = (HsExplicitTupleTy (setAnchorEpa an anc ts cs) a) + setAnnotationAnchor a@(HsExplicitListTy{}) _ _ _s = a + setAnnotationAnchor a@(HsExplicitTupleTy{}) _ _ _s = a setAnnotationAnchor a@(HsTyLit _ _) _ _ _s = a setAnnotationAnchor a@(HsWildCardTy _) _ _ _s = a setAnnotationAnchor a@(XHsType _) _ _ _s = a @@ -4151,30 +4237,30 @@ instance ExactPrint (HsType GhcPs) where NoSourceText -> return an SourceText src -> do debugM $ "HsBangTy: src=" ++ showAst src - an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src) - an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}") + an0 <- markEpAnnMS' an AnnOpen (Just $ unpackFS src) + an1 <- markEpAnnMS' an0 AnnClose (Just "#-}") debugM $ "HsBangTy: done unpackedness" return an1 an1 <- case str of - SrcLazy -> markEpAnnL an0 lidl AnnTilde - SrcStrict -> markEpAnnL an0 lidl AnnBang + SrcLazy -> mark' an0 AnnTilde + SrcStrict -> mark' an0 AnnBang NoSrcStrict -> return an0 ty' <- markAnnotated ty return (HsBangTy an1 (HsSrcBang mt up str) ty') exact (HsExplicitListTy an prom tys) = do an0 <- if (isPromoted prom) - then markEpAnnL an lidl AnnSimpleQuote + then mark' an AnnSimpleQuote else return an - an1 <- markEpAnnL an0 lidl AnnOpenS + an1 <- mark' an0 AnnOpenS tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseS + an2 <- mark' an1 AnnCloseS return (HsExplicitListTy an2 prom tys') exact (HsExplicitTupleTy an tys) = do - an0 <- markEpAnnL an lidl AnnSimpleQuote - an1 <- markEpAnnL an0 lidl AnnOpenP + an0 <- mark' an AnnSimpleQuote + an1 <- mark' an0 AnnOpenP tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseP + an2 <- mark' an1 AnnCloseP return (HsExplicitTupleTy an2 tys') exact (HsTyLit a lit) = do case lit of View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b0429b242c14d008ff59a0bbd2e5133860579bb7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b0429b242c14d008ff59a0bbd2e5133860579bb7 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 Dec 8 14:23:07 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Fri, 08 Dec 2023 09:23:07 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/eras-profiling Message-ID: <657326cb16b8e_3478bcc16a54c170883@gitlab.mail> Matthew Pickering pushed new branch wip/eras-profiling at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/eras-profiling 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 Dec 8 14:36:12 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 08 Dec 2023 09:36:12 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/case-binder-arity Message-ID: <657329dc25655_3478bcc16a54c175527@gitlab.mail> Sebastian Graf pushed new branch wip/case-binder-arity at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/case-binder-arity 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 Dec 8 14:51:38 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 08 Dec 2023 09:51:38 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/dtrace Message-ID: <65732d7a9d101_3478bcccf3684181413@gitlab.mail> Ben Gamari pushed new branch wip/dtrace at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dtrace 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 Dec 8 14:56:11 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 08 Dec 2023 09:56:11 -0500 Subject: [Git][ghc/ghc][wip/dtrace] 3 commits: hadrian: support building dtrace probes Message-ID: <65732e8b765d5_3478bcccf7a90185247@gitlab.mail> Ben Gamari pushed to branch wip/dtrace at Glasgow Haskell Compiler / GHC Commits: c6f16ce1 by Ben Gamari at 2023-12-08T09:39:25-05:00 hadrian: support building dtrace probes This fixes DTrace support in the RTS, implements support in Hadrian, and introduces support on Linux platforms via SystemTap. Fixes #18133. Co-Authored-By: Doug Wilson Co-Authored-By: @adamse - - - - - 3755f841 by Ben Gamari at 2023-12-08T09:41:20-05:00 configure: check for ld.gold bug 27775 and disable DTrace probes for linux in CI - - - - - cb6aa2f9 by Douglas Wilson at 2023-12-08T09:41:20-05:00 tests: Add a test for dtrace probe points - - - - - 16 changed files: - configure.ac - hadrian/cfg/system.config.in - hadrian/src/Builder.hs - hadrian/src/Expression.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Rts.hs - hadrian/src/Settings/Packages.hs - + m4/check_for_gold_t27775.m4 - rts/RtsProbes.d - + testsuite/tests/rts/Dtrace.hs - testsuite/tests/rts/Makefile - testsuite/tests/rts/all.T - + testsuite/tests/rts/dtrace.sh - + testsuite/tests/rts/dtrace.stdout Changes: ===================================== configure.ac ===================================== @@ -752,7 +752,7 @@ AC_PATH_PROGS(PatchCmd,gpatch patch, patch) dnl ** check for autoreconf AC_PATH_PROG(AutoreconfCmd, autoreconf, autoreconf) -dnl ** check for dtrace (currently only implemented for Mac OS X) +dnl ** check for dtrace AC_ARG_ENABLE(dtrace, [AS_HELP_STRING([--enable-dtrace], [Enable DTrace])], @@ -763,17 +763,51 @@ AC_ARG_ENABLE(dtrace, HaveDtrace=NO AC_PATH_PROG(DtraceCmd,dtrace) + if test "x$EnableDtrace" = "xyes"; then if test -n "$DtraceCmd"; then if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple" \ -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xfreebsd-portbld" \ + -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xlinux-unknown" \ -o "x$TargetOS_CPP-$TargetVendor_CPP" = "xsolaris2-unknown"; then HaveDtrace=YES fi fi fi + +if test "x$EnableDtrace" = "xyes" \ + -a "x$HaveDtrace" = "xYES" \ + -a "x$TargetOS_CPP-$TargetVendor_CPP" = "xlinux-unknown"; then + CHECK_FOR_GOLD_T27775([$LD]) + if test "$result" = "1"; then + AC_MSG_WARN([ld.gold is affected by binutils bug 27775. The RTS dtrace probes will not work with statically linked executables. Use a different linker if you need this.]) + fi +fi + AC_SUBST(HaveDtrace) +dnl ** check for libsystemtap + +AC_ARG_WITH([libsystemtap-includes], + [AC_HELP_STRING([--with-libsystemtap-includes=ARG], + [Find includes for libsystemtap in ARG (for DTrace probes on linux) [default=system default]])], + [LibsystemtapIncludeDir="$withval"; LIBSYSTEMTAP_CFLAGS="-I$withval"]) + +AC_SUBST(LibsystemtapIncludeDir) + +if test "x$HaveDtrace" = "xYES" \ + -a "x$TargetOS_CPP-$TargetVendor_CPP" = "xlinux-unknown"; then + CFLAGS2="$CFLAGS" + CFLAGS="$LIBSYSTEMTAP_CFLAGS $CFLAGS" + + AC_CHECK_HEADER([sys/sdt.h], + [], + [AC_MSG_ERROR([DTrace support on Linux needs sys/sdt.h header])]) + + CFLAGS="$CFLAGS2" +fi + + AC_PATH_PROG(HSCOLOUR,HsColour) # HsColour is passed to Cabal, so we need a native path if test "$HostOS" = "mingw32" && \ ===================================== hadrian/cfg/system.config.in ===================================== @@ -24,6 +24,7 @@ makeinfo = @MAKEINFO@ bourne-shell = @SH@ git = @GIT@ cabal = @CABAL@ +dtrace = @DtraceCmd@ # Python 3 is required to run test driver. # See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220 @@ -116,6 +117,8 @@ libnuma-lib-dir = @LibNumaLibDir@ libzstd-include-dir = @LibZstdIncludeDir@ libzstd-lib-dir = @LibZstdLibDir@ +libsystemtap-include-dir = @LibsystemtapIncludeDir@ + # Optional Dependencies: #======================= @@ -129,3 +132,4 @@ use-lib-dl = @UseLibdl@ use-lib-bfd = @UseLibbfd@ use-lib-pthread = @UseLibpthread@ need-libatomic = @NeedLibatomic@ +use-dtrace = @HaveDtrace@ ===================================== hadrian/src/Builder.hs ===================================== @@ -4,6 +4,7 @@ module Builder ( ArMode (..), CcMode (..), ConfigurationInfo (..), DependencyType (..), GhcMode (..), GhcPkgMode (..), HaddockMode (..), TestMode(..), SphinxMode (..), TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..), + DtraceMode (..), -- * Builder properties builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilders, @@ -149,7 +150,23 @@ instance Binary Win32TarballsMode instance Hashable Win32TarballsMode instance NFData Win32TarballsMode +-- | Note [Dtrace probes] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We use Dtrace to define "User statically defined tracepoints" (USDTs) for +-- the RTS. (See @rts/RtsProbes.d@ for the probe declarations.) +-- +-- The Dtrace compiler reads the probe declaration and produces: +-- +-- * A header file. Contains function like C-macros that you use to place the tracepoints. +-- * A stub object. An object file containing implementation details +-- for the probes, must be linked with the final executable or object. Not needed for the +-- Macos implementation of dtrace. +data DtraceMode = DtraceHeader | DtraceStub deriving (Eq, Generic, Show) +instance Binary DtraceMode +instance Hashable DtraceMode +instance NFData DtraceMode -- | A 'Builder' is a (usually external) command invoked in a separate process -- via 'cmd'. Here are some examples: @@ -166,6 +183,7 @@ data Builder = Alex | Cc CcMode Stage | Configure FilePath | DeriveConstants + | Dtrace DtraceMode | GenApply | GenPrimopCode | Ghc GhcMode Stage @@ -385,6 +403,12 @@ instance H.Builder Builder where when (code /= ExitSuccess) $ do fail "tests failed" + Dtrace mode -> do + let modeFlag = case mode of + DtraceHeader -> "-h" + DtraceStub -> "-G" + cmd' [path] buildArgs modeFlag [ "-o", output ] [ "-s", input ] + _ -> cmd' [path] buildArgs buildOptions -- | Invoke @haddock@ given a path to it and a list of arguments. The arguments @@ -425,6 +449,7 @@ systemBuilderPath builder = case builder of Configure _ -> return "configure" Ghc _ (Stage0 {}) -> fromKey "system-ghc" GhcPkg _ (Stage0 {}) -> fromKey "system-ghc-pkg" + Dtrace _ -> fromKey "dtrace" Happy -> fromKey "happy" HsCpp -> fromTargetTC "hs-cpp" (Toolchain.hsCppProgram . tgtHsCPreprocessor) Ld _ -> fromTargetTC "ld" (Toolchain.ccLinkProgram . tgtCCompilerLink) ===================================== hadrian/src/Expression.hs ===================================== @@ -94,6 +94,13 @@ instance BuilderPredicate a => BuilderPredicate (TestMode -> a) where Testsuite mode -> builder (f mode) _ -> return False +instance BuilderPredicate a => BuilderPredicate (DtraceMode -> a) where + builder f = do + b <- getBuilder + case b of + Dtrace mode -> builder (f mode) + _ -> return False + -- | Is the current build 'Way' equal to a certain value? way :: Way -> Predicate way w = (w ==) <$> getWay ===================================== hadrian/src/Oracles/Flag.hs ===================================== @@ -28,6 +28,7 @@ data Flag = CrossCompiling | UseSystemFfi | BootstrapThreadedRts | BootstrapEventLoggingRts + | UseDtrace | UseLibdw | UseLibnuma | UseLibzstd @@ -52,6 +53,7 @@ flag f = do UseSystemFfi -> "use-system-ffi" BootstrapThreadedRts -> "bootstrap-threaded-rts" BootstrapEventLoggingRts -> "bootstrap-event-logging-rts" + UseDtrace -> "use-dtrace" UseLibdw -> "use-lib-dw" UseLibnuma -> "use-lib-numa" UseLibzstd -> "use-lib-zstd" ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -55,6 +55,7 @@ data Setting = CursesIncludeDir | GmpLibDir | IconvIncludeDir | IconvLibDir + | LibsystemtapIncludeDir | LibdwIncludeDir | LibdwLibDir | LibnumaIncludeDir @@ -111,6 +112,7 @@ setting key = lookupSystemConfig $ case key of GmpLibDir -> "gmp-lib-dir" IconvIncludeDir -> "iconv-include-dir" IconvLibDir -> "iconv-lib-dir" + LibsystemtapIncludeDir -> "libsystemtap-include-dir" LibdwIncludeDir -> "libdw-include-dir" LibdwLibDir -> "libdw-lib-dir" LibnumaIncludeDir -> "libnuma-include-dir" ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -11,6 +11,7 @@ import Expression hiding (way, package, stage) import Oracles.ModuleFiles import Packages import Rules.Gmp +import Rules.Rts (rtsDtraceProbes) import Rules.Register import Settings import Target @@ -209,6 +210,8 @@ extraObjects context "gmp" -> gmpObjects (stage context) _ -> return [] + | package context == rts = rtsDtraceProbes (stage context) + | otherwise = return [] -- | Return all the object files to be put into the library we're building for ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -1,13 +1,16 @@ {-# LANGUAGE MultiWayIf #-} -module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks) where +module Rules.Rts (rtsRules, needRtsLibffiTargets, needRtsSymLinks, rtsDtraceProbes) where import qualified Data.Set as Set +import GHC.Platform.ArchOS import Packages (rts, rtsBuildPath, libffiBuildPath, rtsContext) import Rules.Libffi import Hadrian.Utilities import Settings.Builders.Common +import Utilities +import Target -- | This rule has priority 3 to override the general rule for generating shared -- library files (see Rules.Library.libraryRules). @@ -25,10 +28,14 @@ rtsRules = priority 3 $ do (addRtsDummyVersion $ takeFileName rtsLibFilePath') rtsLibFilePath' - -- Libffi forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do let buildPath = root -/- buildDir (rtsContext stage) + -- Dtrace + buildPath -/- "include" -/- "RtsProbes.h" %> buildRtsDtraceProbes stage DtraceHeader + buildPath -/- "RtsProbes.o" %> buildRtsDtraceProbes stage DtraceStub + + -- Libffi -- Header files -- See Note [Packaging libffi headers] in GHC.Driver.CodeOutput. forM_ libffiHeaderFiles $ \header -> @@ -42,6 +49,40 @@ rtsRules = priority 3 $ do buildPath -/- "libffi*.so*" %> copyLibffiDynamicUnix stage ".so" buildPath -/- "libffi*.dll*" %> copyLibffiDynamicWin stage +buildRtsDtraceProbes :: Stage -> DtraceMode -> FilePath -> Action () +buildRtsDtraceProbes stage what out = + build (target (rtsContext stage) (Dtrace what) ["rts/RtsProbes.d"] [out]) + +-- | see Note [Dtrace probes] in @src/Builder.hs at . +rtsDtraceProbes :: Stage -> Action [FilePath] +rtsDtraceProbes stage = do + withDtrace <- flag UseDtrace + osRequiresStub <- anyTargetOs [OSLinux, OSSolaris2, OSFreeBSD] + buildPath <- rtsBuildPath stage + + need (map + (buildPath -/-) + ["include/ghcautoconf.h", "include/ghcplatform.h"]) + + header <- + if withDtrace + then do + let out = buildPath -/- "include/RtsProbes.h" + return [out] + else return [] + + obj <- + if withDtrace && osRequiresStub + then do + let obj = buildPath -/- "RtsProbes.o" + return [obj] + else return [] + + -- we build both the header and the obj, but we only link the obj into the + -- rts library + need (header ++ obj) + return obj + withLibffi :: Stage -> (FilePath -> FilePath -> Action a) -> Action a withLibffi stage action = needLibffi stage >> (join $ action <$> libffiBuildPath stage ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -298,12 +298,13 @@ rtsPackageArgs = package rts ? do libnumaLibraryDir <- getSetting LibnumaLibDir libzstdIncludeDir <- getSetting LibZstdIncludeDir libzstdLibraryDir <- getSetting LibZstdLibDir - + libsystemtapIncludeDir <- getSetting LibsystemtapIncludeDir -- Arguments passed to GHC when compiling C and .cmm sources. let ghcArgs = mconcat [ arg "-Irts" , arg $ "-I" ++ path + , flag UseDtrace ? arg "-DDTRACE" , way `elem` [debug, debugDynamic] ? pure [ "-DTICKY_TICKY" , "-optc-DTICKY_TICKY"] , Profiling `wayUnit` way ? arg "-DPROFILING" @@ -311,9 +312,25 @@ rtsPackageArgs = package rts ? do , notM targetSupportsSMP ? arg "-optc-DNOSMP" ] + let includes = fmap (fmap ("-I" ++)) $ mconcat + [ flag UseSystemFfi ? arg ffiIncludeDir + , flag UseLibdw ? arg libdwIncludeDir + , arg "rts" + , arg path + , if not (null libsystemtapIncludeDir) then arg libsystemtapIncludeDir else mempty + ] + + let dtraceArgs = mconcat + [ arg "-C" -- runs the preprocessor + , arg "-Irts" + , arg ("-I" <> (path "include")) + , arg "-Irts/include" + ] + let cArgs = mconcat [ rtsWarnings , wayCcArgs + , flag UseDtrace ? arg "-DDTRACE" , arg "-fomit-frame-pointer" -- RTS *must* be compiled with optimisations. The INLINE_HEADER macro -- requires that functions are inlined to work as expected. Inlining @@ -362,7 +379,7 @@ rtsPackageArgs = package rts ? do , "-DRtsWay=\"rts_" ++ show way ++ "\"" ] - -- We're after pur performance here. So make sure fast math and + -- We're after pure performance here. So make sure fast math and -- vectorization is enabled. , input "**/Hash.c" ? pure [ "-O3" ] @@ -431,6 +448,7 @@ rtsPackageArgs = package rts ? do , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs , builder (Ghc CompileCppWithGhc) ? map ("-optcxx" ++) <$> cArgs , builder Ghc ? ghcArgs + , builder Dtrace ? dtraceArgs , builder HsCpp ? pure [ "-DTOP=" ++ show top ] ===================================== m4/check_for_gold_t27775.m4 ===================================== @@ -0,0 +1,55 @@ +# CHECK_FOR_GOLD_T27775 +# ---------------------- +# +# Test for binutils #27775. +# +# Uses test from +# https://sourceware.org/bugzilla/show_bug.cgi?id=27775 +# +# $1 = linker to test +# Sets $result to 0 if not affected, 1 otherwise +AC_DEFUN([CHECK_FOR_GOLD_T27775],[ + AC_REQUIRE([FIND_LD]) + AC_MSG_CHECKING([for ld.gold gc-sections with note section bug (binutils 27775)]) + if ! $1 --version | grep -q "GNU gold"; then + # Not gold + result=0 + else + FPTOOLS_WRITE_FILE([conftest.a.s], [ + .section .note.stapsdt,"?","note" + .dc.a _.stapsdt.base + .section .stapsdt.base,"aG","progbits",.stapsdt.base,comdat + _.stapsdt.base: .space 1 + .size _.stapsdt.base,1 + ]) + + FPTOOLS_WRITE_FILE([conftest.b.s], [ + .text + .global start /* Used by SH targets. */ + start: + .global _start + _start: + .global __start + __start: + .global main /* Used by HPPA targets. */ + main: + .dc.a 0 + ]) + + $CC -c -o conftest.a.o conftest.a.s || AC_MSG_ERROR([Failed to compile test]) + $CC -c -o conftest.b.o conftest.b.s || AC_MSG_ERROR([Failed to compile test]) + if $1 --gc-sections -o conftest conftest.a.o conftest.b.o; then + AC_MSG_RESULT([not affected]) + result=0 + else + AC_MSG_RESULT([affected]) + result=1 + fi + + rm -f conftest.a.o conftest.a.s conttest.b.o conftest.b.c conftest + + if test "$result" = "1"; then + AC_MSG_ERROR([ld.gold suffers from bugs with dtrace probes, turn off dtrace or use another linker]) + fi + fi +]) ===================================== rts/RtsProbes.d ===================================== @@ -58,7 +58,7 @@ provider HaskellEvent { probe migrate__thread (EventCapNo, EventThreadID, EventCapNo); probe thread_wakeup (EventCapNo, EventThreadID, EventCapNo); probe create__spark__thread (EventCapNo, EventThreadID); - probe thread__label (EventCapNo, EventThreadID, char *); + probe thread__label (EventCapNo, EventThreadID, char *, int); /* GC and heap events */ probe gc__start (EventCapNo); ===================================== testsuite/tests/rts/Dtrace.hs ===================================== @@ -0,0 +1,10 @@ +{-# language NumericUnderscores #-} + +import Debug.Trace +import Control.Concurrent + +main :: IO () +main = do + -- Pause for 500ms so we don't finish before bpftrace attaches + threadDelay 500_000 + traceEventIO "dtrace works" ===================================== testsuite/tests/rts/Makefile ===================================== @@ -162,3 +162,7 @@ HSC2HS_OPTS = --cc="$(TEST_CC)" $(addprefix --cflag=,$(TEST_CC_OPTS)) --ld=$(TES IOManager.hs: IOManager.hsc '$(HSC2HS)' $(HSC2HS_OPTS) $< + +.PHONY: dtrace +dtrace: + ./dtrace.sh ===================================== testsuite/tests/rts/all.T ===================================== @@ -608,3 +608,5 @@ test('T23400', [], compile_and_run, ['-with-rtsopts -A8k']) test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), skip), pre_cmd('$MAKE -s --no-print-directory IOManager.hs')], compile_and_run, ['']) + +test('dtrace', [extra_files(['Dtrace.hs', 'dtrace.sh'])], makefile_test, ['dtrace']) ===================================== testsuite/tests/rts/dtrace.sh ===================================== @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +set -euo pipefail +"$TEST_HC" $TEST_HC_OPTS -eventlog Dtrace.hs -v0 +./Dtrace & sudo bpftrace -q -e "usdt::HaskellEvent:user__msg { printf(\"%s\n\", str(arg1)); }" -p $! ===================================== testsuite/tests/rts/dtrace.stdout ===================================== @@ -0,0 +1,3 @@ +dtrace works + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5281d38d0f56a712adf1f0310e94abdce8c4fad...cb6aa2f9a2c5346cca431766d912aa4c9a1d68fa -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c5281d38d0f56a712adf1f0310e94abdce8c4fad...cb6aa2f9a2c5346cca431766d912aa4c9a1d68fa 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 Dec 8 14:56:45 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 08 Dec 2023 09:56:45 -0500 Subject: [Git][ghc/ghc][wip/T20749] 209 commits: EPA: Introduce HasAnnotation class Message-ID: <65732eadd3818_3478bcd015c68186017@gitlab.mail> Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 645de464 by Sebastian Graf at 2023-12-08T15:54:12+01:00 Make DataCon workers strict in strict fields (#20749) This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand Analysis so that they exploit and maintain strictness of DataCon workers. See `Note [Strict fields in Core]` for details. Very little needed to change, and it puts field seq insertion done by Tag Inference into a new perspective: That of *implementing* strict field semantics. Before Tag Inference, DataCon workers are strict. Afterwards they are effectively lazy and field seqs happen around use sites. History has shown that there is no other way to guarantee taggedness and thus the STG Strict Field Invariant. Knock-on changes: * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments instead of recursing into `exprIsHNF`. That regressed the termination analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made it call `exprOkForSpeculation`, too. * There's a small regression in Demand Analysis, visible in the changed test output of T16859: Previously, a field seq on a variable would give that variable a "used exactly once" demand, now it's "used at least once", because `dmdTransformDataConSig` accounts for future uses of the field that actually all go through the case binder (and hence won't re-enter the potential thunk). The difference should hardly be observable. * The Simplifier's fast path for data constructors only applies to lazy data constructors now. I observed regressions involving Data.Binary.Put's `Pair` data type. * Unfortunately, T21392 does no longer reproduce after this patch, so I marked it as "not broken" in order to track whether we regress again in the future. Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas in #21497 and #22475). Co-authored-by: Jaro Reinders <jaro.reinders at gmail.com> - - - - - 30 changed files: - .ghcid - .gitignore - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/merge_request_templates/Default.md - .gitlab/rel_eng/upload.sh - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - 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/AArch64/Regs.hs - compiler/GHC/CmmToAsm/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/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.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/7febfe8f1790eb79e325529bc23763bd47d6a2a1...645de46464656e99bec956b720b23e26e2d6fbed -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7febfe8f1790eb79e325529bc23763bd47d6a2a1...645de46464656e99bec956b720b23e26e2d6fbed 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 Dec 8 15:40:54 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 08 Dec 2023 10:40:54 -0500 Subject: [Git][ghc/ghc][wip/T24242] 17 commits: Only exit ghci in -e mode when :add command fails Message-ID: <6573390664a08_3478bce450c281978ad@gitlab.mail> Simon Peyton Jones pushed to branch wip/T24242 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6046a0061bfbc600c91037e4c34c9708e0084faa...d8baa1bdeea1753afc939a20119d3ce555301167 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6046a0061bfbc600c91037e4c34c9708e0084faa...d8baa1bdeea1753afc939a20119d3ce555301167 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 Dec 8 16:12:12 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 08 Dec 2023 11:12:12 -0500 Subject: [Git][ghc/ghc][wip/T20749] Make DataCon workers strict in strict fields (#20749) Message-ID: <6573405c71517_3478bcef48e642091b@gitlab.mail> Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC Commits: 8a329a3e by Sebastian Graf at 2023-12-08T17:11:45+01:00 Make DataCon workers strict in strict fields (#20749) This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand Analysis so that they exploit and maintain strictness of DataCon workers. See `Note [Strict fields in Core]` for details. Very little needed to change, and it puts field seq insertion done by Tag Inference into a new perspective: That of *implementing* strict field semantics. Before Tag Inference, DataCon workers are strict. Afterwards they are effectively lazy and field seqs happen around use sites. History has shown that there is no other way to guarantee taggedness and thus the STG Strict Field Invariant. Knock-on changes: * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments instead of recursing into `exprIsHNF`. That regressed the termination analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made it call `exprOkForSpeculation`, too. * There's a small regression in Demand Analysis, visible in the changed test output of T16859: Previously, a field seq on a variable would give that variable a "used exactly once" demand, now it's "used at least once", because `dmdTransformDataConSig` accounts for future uses of the field that actually all go through the case binder (and hence won't re-enter the potential thunk). The difference should hardly be observable. * The Simplifier's fast path for data constructors only applies to lazy data constructors now. I observed regressions involving Data.Binary.Put's `Pair` data type. * Unfortunately, T21392 does no longer reproduce after this patch, so I marked it as "not broken" in order to track whether we regress again in the future. Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas in #21497 and #22475). Co-authored-by: Jaro Reinders <jaro.reinders at gmail.com> - - - - - 21 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Utils/Misc.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplStg/should_compile/inferTags002.stderr - testsuite/tests/stranal/sigs/T16859.stderr Changes: ===================================== compiler/GHC/Builtin/Types.hs ===================================== @@ -636,6 +636,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri -- See Note [Constructor tag allocation] and #14657 data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) + (map (const HsLazy) arg_tys) + (map (const NotMarkedStrict) arg_tys) [] -- No labelled fields tyvars ex_tyvars conc_tyvars ===================================== compiler/GHC/Core.hs ===================================== @@ -42,7 +42,7 @@ module GHC.Core ( foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, collectFunSimple, exprToType, @@ -1005,6 +1005,59 @@ tail position: A cast changes the type, but the type must be the same. But operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Evaluating a data constructor worker evaluates its strict fields. + +In other words, if `MkT` is strict in its first field and `xs` reduces to +`error "boom"`, then `MkT xs b` will throw that error. +Conversely, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field seq insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + + * `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + + * `exprIsConApp_maybe` inserts field seqs in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. + all see the inserted field seqs when they match on strict workers. Often this + is just to emphasise strict semantics, but for case-of-known constructor + and case-to-let, field insertion is *vital*, otherwise these transformations + would lose field seqs. + + * The demand signature of a data constructor is strict in strict field + position, whereas is it's normally lazy. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + + * In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited in STG by Note [Tag Inference]: +It performs field seq insertion to statically guarantee *taggedness* of strict +fields, establishing the Note [STG Strict Field Invariant]. (Happily, most +of those seqs are immediately detected as redundant by tag inference and are +omitted.) From then on, DataCon worker semantics are actually lazy, hence it is +important that STG passes maintain the Strict Field Invariant. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + ************************************************************************ * * In/Out type synonyms @@ -2091,6 +2144,17 @@ collectArgs expr go (App f a) as = go f (a:as) go e as = (e, as) +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectValArgs :: Expr b -> (Expr b, [Arg b]) +collectValArgs expr + = go expr [] + where + go (App f a) as + | isValArg a = go f (a:as) + | otherwise = go f as + go e as = (e, as) + -- | Takes a nested application expression and returns the function -- being applied. Looking through casts and ticks to find it. collectFunSimple :: Expr b -> Expr b ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -49,7 +49,8 @@ module GHC.Core.DataCon ( dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, + dataConRepStrictness, dataConRepStrictness_maybe, + dataConImplBangs, dataConBoxer, splitDataProductType_maybe, @@ -60,7 +61,7 @@ module GHC.Core.DataCon ( isVanillaDataCon, isNewDataCon, isTypeDataCon, classDataCon, dataConCannotMatch, dataConUserTyVarsNeedWrapper, checkDataConTyVars, - isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, + isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, -- ** Promotion related functions @@ -97,6 +98,7 @@ import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) import GHC.Data.Graph.UnVar -- UnVarSet and operations +import GHC.Data.Maybe (orElse) import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars ) @@ -524,6 +526,18 @@ data DataCon -- Matches 1-1 with dcOrigArgTys -- Hence length = dataConSourceArity dataCon + dcImplBangs :: [HsImplBang], + -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + dcStricts :: [StrictnessMark], + -- One mark for every field of the DataCon worker; + -- if it's empty, then all fields are lazy, + -- otherwise it has the same length as dataConRepArgTys. + -- See also Note [Strict fields in Core] in GHC.Core + -- for the effect on the strictness signature + dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the dcOrigArgTys; @@ -826,13 +840,6 @@ data DataConRep -- after unboxing and flattening, -- and *including* all evidence args - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - } type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon @@ -901,43 +908,8 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) -{- Note [Data-con worker strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we do *not* say the worker Id is strict even if the data -constructor is declared strict - e.g. data T = MkT ![Int] Bool -Even though most often the evals are done by the *wrapper* $WMkT, there are -situations in which tag inference will re-insert evals around the worker. -So for all intents and purposes the *worker* MkT is strict, too! - -Unfortunately, if we exposed accurate strictness of DataCon workers, we'd -see the following transformation: - - f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs - ==> { drop-seq, binder swap on xs' } - f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs - ==> { case-to-let } - f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs! - -I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs` -and then doing case-to-let. The issue is that `exprIsHNF` currently says that -every DataCon worker app is a value. The implicit assumption is that surrounding -evals will have evaluated strict fields like `xs` before! But now that we had -just dropped the eval on `xs`, that assumption is no longer valid. - -Long story short: By keeping the demand signature lazy, the Simplifier will not -drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others -remains sound. - -Similarly, during demand analysis in dmdTransformDataConSig, we bump up the -field demand with `C_01`, *not* `C_11`, because the latter exposes too much -strictness that will drop the eval on `xs` above. - -This issue is discussed at length in -"Failed idea: no wrappers for strict data constructors" in #21497 and #22475. - -Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -963,8 +935,8 @@ Terminology: the flag settings in the importing module. Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be +* The dcImplBangs field records the [HsImplBang] + If T was defined in this module, Without -O the dcImplBangs might be [HsStrict _, HsStrict _, HsLazy] With -O it might be [HsStrict _, HsUnpack _, HsLazy] @@ -973,6 +945,17 @@ Terminology: With -XStrictData it might be [HsStrict _, HsUnpack _, HsStrict _] +* Core passes will often need to know whether the DataCon worker or wrapper in + an application is strict in some (lifted) field or not. This is tracked in the + demand signature attached to a DataCon's worker resp. wrapper Id. + + So if you've got a DataCon dc, you can get the demand signature by + `idDmdSig (dataConWorkId dc)` and make out strict args by testing with + `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives + you the demand signature of the wrapper, if it exists. + + These demand signatures are set in GHC.Types.Id.Make. + Note [Detecting useless UNPACK pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to issue a warning when there's an UNPACK pragma in the source code, @@ -1008,7 +991,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. - ************************************************************************ * * \subsection{Instances} @@ -1110,6 +1092,11 @@ isBanged (HsUnpack {}) = True isBanged (HsStrict {}) = True isBanged HsLazy = False +isUnpacked :: HsImplBang -> Bool +isUnpacked (HsUnpack {}) = True +isUnpacked (HsStrict {}) = False +isUnpacked HsLazy = False + isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False @@ -1135,13 +1122,15 @@ cbvFromStrictMark MarkedStrict = MarkedCbv -- | Build a new data constructor mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler + -> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. -> ConcreteTyVars -- ^ TyVars which must be instantiated with -- concrete types @@ -1163,7 +1152,9 @@ mkDataCon :: Name -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 + arg_stricts -- Must match orig_arg_tys 1-1 + impl_bangs -- Must match orig_arg_tys 1-1 + str_marks -- Must be empty or match dataConRepArgTys 1-1 fields univ_tvs ex_tvs conc_tvs user_tvbs eq_spec theta @@ -1180,6 +1171,8 @@ mkDataCon name declared_infix prom_info = con where is_vanilla = null ex_tvs && null eq_spec && null theta + str_marks' | not $ any isMarkedStrict str_marks = [] + | otherwise = str_marks con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, @@ -1192,7 +1185,8 @@ mkDataCon name declared_infix prom_info dcStupidTheta = stupid_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, + dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs, + dcStricts = str_marks', dcFields = fields, dcTag = tag, dcRepType = rep_ty, dcWorkId = work_id, dcRep = rep, @@ -1436,19 +1430,27 @@ isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness dc + = dataConRepStrictness_maybe dc + `orElse` map (const NotMarkedStrict) (dataConRepArgTys dc) + +dataConRepStrictness_maybe :: DataCon -> Maybe [StrictnessMark] +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application or `Nothing` if all of them are lazy. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness_maybe dc + | null (dcStricts dc) = Nothing + | otherwise = Just (dcStricts dc) dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs +dataConImplBangs dc = dcImplBangs dc dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -1463,7 +1463,7 @@ myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] - cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -296,9 +296,16 @@ data TermFlag -- Better than using a Bool -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag +-- ^ A /very/ simple termination analysis. exprTerminates e - | exprIsHNF e = Terminates -- A /very/ simple termination analysis. - | otherwise = MightDiverge + | exprIsHNF e = Terminates + | exprOkForSpeculation e = Terminates + | otherwise = MightDiverge + -- Annyingly, we have to check both for HNF and ok-for-spec. + -- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing! + -- * `lvl` is an HNF if its unfolding is evaluated + -- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never + -- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables]. cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) -- Main function that takes care of /nested/ CPR. See Note [Nested CPR] ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -824,6 +824,10 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +You might think that we should check for side-effects rather than just for +precise exceptions. Right you are! See Note [Side-effects and strictness] +for why we unfortunately do not. + Note [Demand analysis for recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T11545 features a single-product, recursive data type ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -8,14 +8,13 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - SimplMode(..), updMode, - smPedanticBottoms, smPlatform, + SimplMode(..), updMode, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, - seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seOptCoercionOpts, sePhase, sePlatform, sePreInline, seRuleOpts, seRules, seUnfoldingOpts, mkSimplEnv, extendIdSubst, extendTvSubst, extendCvSubst, @@ -219,9 +218,6 @@ seNames env = sm_names (seMode env) seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePedanticBottoms :: SimplEnv -> Bool -sePedanticBottoms env = smPedanticBottoms (seMode env) - sePhase :: SimplEnv -> CompilerPhase sePhase env = sm_phase (seMode env) @@ -276,9 +272,6 @@ instance Outputable SimplMode where where pp_flag f s = ppUnless f (text "no") <+> s -smPedanticBottoms :: SimplMode -> Bool -smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) - smPlatform :: SimplMode -> Platform smPlatform opts = roPlatform (sm_rule_opts opts) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Core.Reduction import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness + ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepStrictness_maybe , dataConRepArgTys, isUnboxedTupleDataCon , StrictnessMark (..) ) import GHC.Core.Opt.Stats ( Tick(..) ) @@ -2102,14 +2102,14 @@ zap the SubstEnv. This is VITAL. Consider We'll clone the inner \x, adding x->x' in the id_subst Then when we inline y, we must *not* replace x by x' in the inlined copy!! -Note [Fast path for data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Fast path for lazy data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For applications of a data constructor worker, the full glory of rebuildCall is a waste of effort; * They never inline, obviously * They have no rewrite rules -* They are not strict (see Note [Data-con worker strictness] - in GHC.Core.DataCon) +* Though they might be strict (see Note [Strict fields in Core] in GHC.Core), + we will exploit that strictness through their demand signature So it's fine to zoom straight to `rebuild` which just rebuilds the call in a very straightforward way. @@ -2133,7 +2133,8 @@ simplVar env var simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont - | isDataConWorkId var -- See Note [Fast path for data constructors] + | Just dc <- isDataConWorkId_maybe var -- See Note [Fast path for lazy data constructors] + , Nothing <- dataConRepStrictness_maybe dc = rebuild env (Var var) cont | otherwise = case substId env var of @@ -3318,7 +3319,7 @@ a case pattern. This is *important*. Consider We really must record that b is already evaluated so that we don't go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Core.DataCon +See Note [Strict fields in Core] in GHC.Core. NB: simplLamBndrs preserves this eval info ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1272,11 +1272,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } - = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) - float = FloatCase arg' bndr DEFAULT [] - subst' = subst_extend_in_scope subst bndr - in go subst' (float:floats) fun (CC (Var bndr : args) co) + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) co) | otherwise = go subst floats fun (CC (subst_expr subst arg : args) co) @@ -1315,8 +1312,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args co + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + -- mkFieldSeqFloats: See Note [Strict fields in Core] + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' co -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do @@ -1402,6 +1401,38 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + -- See Note [Strict fields in Core] for what a field seq is and why we + -- insert them + mkFieldSeqFloats in_scope dc args + | Nothing <- dataConRepStrictness_maybe dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = no_seq + | exprIsHNF arg = no_seq + | otherwise = (in_scope', float:floats, Var bndr:args) + where + no_seq = (in_scope, floats, arg:args) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> Coercion ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Core.Type ( splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe, splitForAllTyCoVar_maybe, splitForAllTyCoVar, splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, + splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders, getRuntimeArgTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, @@ -292,6 +292,7 @@ import GHC.Data.FastString import Control.Monad ( guard ) import GHC.Data.Maybe ( orElse, isJust ) +import GHC.List (build) -- $type_classification -- #type_classification# @@ -2004,6 +2005,18 @@ splitPiTys ty = split ty ty [] split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) +collectPiTyBinders :: Type -> [PiTyBinder] +collectPiTyBinders ty = build $ \c n -> + let + split (ForAllTy b res) = Named b `c` split res + split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = Anon (Scaled w arg) af `c` split res + split ty | Just ty' <- coreView ty = split ty' + split _ = n + in + split ty +{-# INLINE collectPiTyBinders #-} + -- | Extracts a list of run-time arguments from a function type, -- looking through newtypes to the right of arrows. -- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -1269,18 +1269,23 @@ in this (which it previously was): in \w. v True -} --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree e = exprIsCheapX isWorkFreeApp e - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap e = exprIsCheapX isCheapApp e +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool {-# INLINE exprIsCheapX #-} --- allow specialization of exprIsCheap and exprIsWorkFree +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable -- instead of having an unknown call to ok_app -exprIsCheapX ok_app e +-- expandable: Only True for exprIsExpandable, where Case and Let are never +-- expandable. +exprIsCheapX ok_app expandable e = ok e where ok e = go 0 e @@ -1299,90 +1304,26 @@ exprIsCheapX ok_app e | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f - go n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + go n (Let (NonRec _ r) e) = not expandable && go n e && ok r + go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs -- Case: see Note [Case expressions are work-free] -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e -{- Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to duplicate it, if doing -so might make a RULE or case-of-constructor fire. Consider - let x = (a,b) - y = build g - in ....(case x of (p,q) -> rhs)....(foldr k z y).... - -We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), -but we do want - - * the case-expression to simplify - (via exprIsConApp_maybe, exprIsLiteral_maybe) - - * the foldr/build RULE to fire - (by expanding the unfolding during rule matching) - -So we classify the unfolding of a let-binding as "expandable" (via the -uf_expandable field) if we want to do this kind of on-the-fly -expansion. Specifically: - -* True of constructor applications (K a b) - -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. - (NB: exprIsCheap might not be true of this) - -* False of case-expressions. If we have - let x = case ... in ...(case x of ...)... - we won't simplify. We have to inline x. See #14688. - -* False of let-expressions (same reason); and in any case we - float lets out of an RHS if doing so will reveal an expandable - application (see SimplEnv.doFloatFromRhs). - -* Take care: exprIsExpandable should /not/ be true of primops. I - found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... - - q's inlining should not be expandable, else exprIsConApp_maybe will - say that (q @ Float) expands to (Ptr a (a +# b)), and that will - duplicate the (a +# b) primop, which we should not do lightly. - (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) --} +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e -------------------------------------- +-------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] -exprIsExpandable e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = isExpandableApp v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Case {}) = False - go _ (Let {}) = False - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp +exprIsExpandable e = exprIsCheapX isExpandableApp True e isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args @@ -1402,7 +1343,7 @@ isCheapApp fn n_val_args | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId op _ -> primOpIsCheap op @@ -1417,6 +1358,7 @@ isExpandableApp fn n_val_args | isWorkFreeApp fn n_val_args = True | otherwise = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False @@ -1448,6 +1390,50 @@ isExpandableApp fn n_val_args I'm not sure why we have a special case for bottoming functions in isCheapApp. Maybe we don't need it. +Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) + Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming @@ -1628,7 +1614,7 @@ expr_ok fun_ok primop_ok other_expr _ -> False ----------------------------- -app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool app_ok fun_ok primop_ok fun args | not (fun_ok fun) = False -- This code path is only taken for Note [Speculative evaluation] @@ -1643,13 +1629,11 @@ app_ok fun_ok primop_ok fun args -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not - DataConWorkId {} -> args_ok - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - -- Well, we thought so. But it's definitely wrong! - -- See #20749 and Note [How untagged pointers can - -- end up in strict fields] in GHC.Stg.InferTags + DataConWorkId dc + | Just str_marks <- dataConRepStrictness_maybe dc + -> fields_ok str_marks + | otherwise + -> args_ok ClassOpId _ is_terminating_result | is_terminating_result -- See Note [exprOkForSpeculation and type classes] @@ -1699,7 +1683,7 @@ app_ok fun_ok primop_ok fun args -- Even if a function call itself is OK, any unlifted -- args are still evaluated eagerly and must be checked - args_ok = and (zipWith arg_ok arg_tys args) + args_ok = all2Prefix arg_ok arg_tys args arg_ok :: PiTyVarBinder -> CoreExpr -> Bool arg_ok (Named _) _ = True -- A type argument arg_ok (Anon ty _) arg -- A term argument @@ -1708,6 +1692,17 @@ app_ok fun_ok primop_ok fun args | otherwise = expr_ok fun_ok primop_ok arg + -- Used for DataCon worker arguments + fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args + field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool + field_ok (Named _) _ _ = True + field_ok (Anon ty _) str arg + | NotMarkedStrict <- str -- iff it's a lazy field + , definitelyLiftedType (scaledThing ty) -- and its type is lifted + = True -- then the worker app does not eval + | otherwise + = expr_ok fun_ok primop_ok arg + ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alternatives are definitely exhaustive @@ -1933,12 +1928,14 @@ exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding -- or PAPs. -- exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like +exprIsHNFlike is_con is_con_unf e + = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $ + is_hnf_like e where is_hnf_like (Var v) -- NB: There are no value args at this point - = id_app_is_value v 0 -- Catches nullary constructors, - -- so that [] and () are values, for example - -- and (e.g.) primops that don't have unfoldings + = id_app_is_value v [] -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value -- or to a guaranteed-evaluated variable (isEvaldUnfolding) @@ -1962,7 +1959,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like -- See Note [exprIsHNF Tick] is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e a) - | isValArg a = app_is_value e 1 + | isValArg a = app_is_value e [a] | otherwise = is_hnf_like e is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like (Case e b _ as) @@ -1970,26 +1967,53 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like = is_hnf_like rhs is_hnf_like _ = False - -- 'n' is the number of value args to which the expression is applied - -- And n>0: there is at least one value argument - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = - app_is_value f (nva + 1) && - not (needsCaseBinding (exprType a) a) - -- For example f (x /# y) where f has arity two, and the first - -- argument is unboxed. This is not a value! - -- But f 34# is a value. - -- NB: Check app_is_value first, the arity check is cheaper - | otherwise = app_is_value f nva - app_is_value _ _ = False - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args + -- Collect arguments through Casts and Ticks and call id_app_is_value + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var f) as = id_app_is_value f as + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as | isValArg a = app_is_value f (a:as) + | otherwise = app_is_value f as + app_is_value _ _ = False + + id_app_is_value id val_args + -- First handle saturated applications of DataCons with strict fields + | Just dc <- isDataConWorkId_maybe id -- DataCon + , Just str_marks <- dataConRepStrictness_maybe dc -- with strict fields + , assert (val_args `leLength` str_marks) True + , val_args `equalLength` str_marks -- in a saturated app + = all3Prefix check_field val_arg_tys str_marks val_args + + -- Now all applications except saturated DataCon apps with strict fields + | idArity id > length val_args + -- PAP: Check unlifted val_args + || is_con id && isNothing (isDataConWorkId_maybe id >>= dataConRepStrictness_maybe) + -- Either a lazy DataCon or a CONLIKE. + -- Hence we only need to check unlifted val_args here. + -- NB: We assume that CONLIKEs are lazy, which is their entire + -- point. + = all2Prefix check_arg val_arg_tys val_args + + | otherwise + = False + where + fun_ty = idType id + val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty) + -- val_arg_tys = map exprType val_args, but much less costly. + -- The obvious definition regresses T16577 by 30% so we don't do it. + + check_arg a_ty a = mightBeUnliftedType a_ty ==> is_hnf_like a + -- Check unliftedness; for example f (x /# 12#) where f has arity two, + -- and the first argument is unboxed. This is not a value! + -- But f 34# is a value, so check args for HNFs. + -- NB: We check arity (and CONLIKEness) first because it's cheaper + -- and we reject quickly on saturated apps. + check_field a_ty str a + = isMarkedStrict str || mightBeUnliftedType a_ty ==> is_hnf_like a + -- isMarkedStrict: Respect Note [Strict fields in Core] + a ==> b = not a || b + infixr 1 ==> +{-# INLINE exprIsHNFlike #-} {- Note [exprIsHNF Tick] @@ -2551,7 +2575,7 @@ This means the seqs on x and y both become no-ops and compared to the first vers The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated -already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this. +already at the call site because of the Strict Field Invariant! See Note [STG Strict Field Invariant] for more in this. This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. We only apply this when we think there is a benefit in doing so however. There are a number of cases in which ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -65,8 +65,8 @@ With nofib being ~0.3% faster as well. See Note [Tag inference passes] for how we proceed to generate and use this information. -Note [Strict Field Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [STG Strict Field Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As part of tag inference we introduce the Strict Field Invariant. Which consists of us saying that: @@ -82,7 +82,7 @@ and will be tagged with `001` or `010` respectively. It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. -This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids]. +This works analogous to how CBV functions work. See also Note [CBV Function Ids]. Why do we care? Because if we have code like: @@ -104,7 +104,7 @@ where we: * If not we convert `StrictJust x` into `case x of x' -> StrictJust x'` This is usually very beneficial but can cause regressions in rare edge cases where -we fail to proof that x is properly tagged, or where it simply isn't. +we fail to prove that x is properly tagged, or where it simply isn't. See Note [How untagged pointers can end up in strict fields] for how the second case can arise. @@ -125,15 +125,33 @@ Note that there are similar constraints around Note [CBV Function Ids]. Note [How untagged pointers can end up in strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the resolution of #20749 where Core passes assume that DataCon workers +evaluate their strict fields, it is pretty simple to see how the Simplifier +might exploit that knowledge to drop evals. Example: + + data MkT a = MkT !a + f :: [Int] -> T [Int] + f xs = xs `seq` MkT xs + +in Core we will have + + f = \xs -> MkT @[Int] xs + +No eval left there. + Consider data Set a = Tip | Bin !a (Set a) (Set a) We make a wrapper for Bin that evaluates its arguments $WBin x a b = case x of xv -> Bin xv a b Here `xv` will always be evaluated and properly tagged, just as the -Strict Field Invariant requires. +Note [STG Strict Field Invariant] requires. + +But alas, the Simplifier can destroy the invariant: see #15696. +Indeed, as Note [Strict fields in Core] explains, Core passes +assume that Data constructor workers evaluate their strict fields, +so the Simplifier will drop seqs freely. -But alas the Simplifier can destroy the invariant: see #15696. We start with thk = f () g x = ...(case thk of xv -> Bin xv Tip Tip)... @@ -154,7 +172,7 @@ Now you can see that the argument of Bin, namely thk, points to the thunk, not to the value as it did before. In short, although it may be rare, the output of optimisation passes -cannot guarantee to obey the Strict Field Invariant. For this reason +cannot guarantee to obey the Note [STG Strict Field Invariant]. For this reason we run tag inference. See Note [Tag inference passes]. Note [Tag inference passes] @@ -164,7 +182,7 @@ Tag inference proceeds in two passes: The result is then attached to /binders/. This is implemented by `inferTagsAnal` in GHC.Stg.InferTags * The second pass walks over the AST checking if the Strict Field Invariant is upheld. - See Note [Strict Field Invariant]. + See Note [STG Strict Field Invariant]. If required this pass modifies the program to uphold this invariant. Tag information is also moved from /binders/ to /occurrences/ during this pass. This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`. ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -65,7 +65,7 @@ The work of this pass is simple: * For any strict field we check if the argument is known to be properly tagged. * If it's not known to be properly tagged, we wrap the whole thing in a case, which will force the argument before allocation. -This is described in detail in Note [Strict Field Invariant]. +This is described in detail in Note [STG Strict Field Invariant]. The only slight complication is that we have to make sure not to invalidate free variable analysis in the process. @@ -218,7 +218,7 @@ When compiling bytecode we call myCoreToStg to get STG code first. myCoreToStg in turn calls out to stg2stg which runs the STG to STG passes followed by free variables analysis and the tag inference pass including its rewriting phase at the end. -Running tag inference is important as it upholds Note [Strict Field Invariant]. +Running tag inference is important as it upholds Note [STG Strict Field Invariant]. While code executed by GHCi doesn't take advantage of the SFI it can call into compiled code which does. So it must still make sure that the SFI is upheld. See also #21083 and #22042. ===================================== compiler/GHC/Tc/TyCl/Build.hs ===================================== @@ -183,14 +183,15 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls + src_bangs impl_bangs str_marks field_lbls univ_tvs ex_tvs noConcreteTyVars user_tvbs eq_spec ctxt arg_tys res_ty NoPromInfo rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) + (dc_rep, impl_bangs, str_marks) = + initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1385,33 +1385,8 @@ arguments. That is the job of dmdTransformDataConSig. More precisely, * it returns the demands on the arguments; in the above example that is [SL, A] -Nasty wrinkle. Consider this code (#22475 has more realistic examples but -assume this is what the demand analyser sees) - - data T = MkT !Int Bool - get :: T -> Bool - get (MkT _ b) = b - - foo = let v::Int = I# 7 - t::T = MkT v True - in get t - -Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand, -else we'll drop the binding and replace it with an error thunk. -Then the code generator (more specifically GHC.Stg.InferTags.Rewrite) -will add an extra eval of MkT's argument to give - foo = let v::Int = error "absent" - t::T = case v of v' -> MkT v' True - in get t - -Boo! Because of this extra eval (added in STG-land), the truth is that `MkT` -may (or may not) evaluate its arguments (as established in #21497). Hence the -use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The -`C_01` says "may or may not evaluate" which is absolutely faithful to what -InferTags.Rewrite does. - -In particular it is very important /not/ to make that a `C_11` eval, -see Note [Data-con worker strictness]. +When the data constructor worker has strict fields, they act as additional +seqs; hence we add an additional `C_11` eval. -} {- ********************************************************************* @@ -1611,6 +1586,29 @@ a bad fit because expression may not throw a precise exception (increasing precision of the analysis), but that's just a favourable guess. +Note [Side-effects and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to historic reasons and the continued effort not to cause performance +regressions downstream, Strictness Analysis is currently prone to discarding +observable side-effects (other than precise exceptions, see +Note [Precise exceptions and strictness analysis]) in some cases. For example, + f :: MVar () -> Int -> IO Int + f mv x = putMVar mv () >> (x `seq` return x) +The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis +currently concludes that `f` is strict in `x` and uses call-by-value. +That means `f mv (error "boom")` will error out with the imprecise exception +rather performing the side-effect. + +This is a conscious violation of the semantics described in the paper +"a semantics for imprecise exceptions"; so it would be great if we could +identify the offending primops and extend the idea in +Note [Which scrutinees may throw precise exceptions] to general side-effects. + +Unfortunately, the existing has-side-effects classification for primops is +too conservative, listing `writeMutVar#` and even `readMutVar#` as +side-effecting. That is due to #3207. A possible way forward is described in +#17900, but no effort has been so far towards a resolution. + Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore. @@ -2327,7 +2325,7 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) | otherwise = multDmd n dmd - str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness] + str_field_dmd = C_11 :* seqSubDmd -- See Note [Strict fields in Core] -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -260,7 +260,7 @@ The invariants around the arguments of call by value function like Ids are then: * Any `WorkerLikeId` * Some `JoinId` bindings. -This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant]. +This works analogous to the Strict Field Invariant. See also Note [STG Strict Field Invariant]. To make this work what we do is: * During W/W and SpecConstr any worker/specialized binding we introduce ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -58,7 +58,7 @@ import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) +import GHC.Core.Utils ( exprType, mkCast, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -594,8 +594,12 @@ mkDataConWorkId wkr_name data_con = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + str_marks = dataConRepStrictness data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo @@ -603,12 +607,19 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedDmdSig wkr_dmds topDiv + wkr_dmds = map mk_dmd str_marks + mk_dmd MarkedStrict = evalDmd + mk_dmd NotMarkedStrict = topDmd + -- See Note [LFInfo of DataCon workers and wrappers] wkr_lf_info | wkr_arity == 0 = LFCon data_con @@ -616,9 +627,6 @@ mkDataConWorkId wkr_name data_con -- LFInfo stores post-unarisation arity ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - ex_tcvs = dataConExTyCoVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` dataConWrapperInlinePragma @@ -786,10 +794,10 @@ mkDataConRep :: DataConBangOpts -> FamInstEnvs -> Name -> DataCon - -> UniqSM DataConRep + -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) mkDataConRep dc_bang_opts fam_envs wrap_name data_con | not wrapper_reqd - = return NoDataConRep + = return (NoDataConRep, arg_ibangs, rep_strs) | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys @@ -853,11 +861,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } + , dcr_arg_tys = rep_tys } + , arg_ibangs, rep_strs) } where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) @@ -907,8 +912,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. - && (any isBanged (ev_ibangs ++ arg_ibangs))) - -- Some forcing/unboxing (includes eq_spec) + && (any isUnpacked (ev_ibangs ++ arg_ibangs))) + -- Some unboxing (includes eq_spec) || isFamInstTyCon tycon -- Cast result || (dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and @@ -1185,7 +1190,7 @@ dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep arg_ty (HsStrict _) - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG dataConArgRep arg_ty (HsUnpack Nothing) = dataConArgUnpack arg_ty @@ -1215,9 +1220,6 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Utils.Misc ( dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, - List.foldl1', foldl2, count, countWhile, all2, + List.foldl1', foldl2, count, countWhile, all2, all2Prefix, all3Prefix, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -663,6 +663,30 @@ all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False +all2Prefix :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`. +-- So if one list is shorter than the other, `p` is assumed to be `True` for the +-- suffix. +all2Prefix p = foldr k z + where + k x go ys' = case ys' of + (y:ys'') -> p x y && go ys'' + _ -> True + z _ = True +{-# INLINE all2Prefix #-} + +all3Prefix :: (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool +-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`. +-- So if one list is shorter than the others, `p` is assumed to be `True` for +-- the suffix. +all3Prefix p = foldr k z + where + k x go ys' zs' = case (ys',zs') of + (y:ys'',z:zs'') -> p x y z && go ys'' zs'' + _ -> False + z _ _ = True +{-# INLINE all3Prefix #-} + -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -418,7 +418,10 @@ test('T21391', normal, compile, ['-O -dcore-lint']) test('T22112', [ grep_errmsg('never matches') ], compile, ['-O -dsuppress-uniques -dno-typeable-binds -fexpose-all-unfoldings -ddump-simpl']) test('T21391a', normal, compile, ['-O -dcore-lint']) # We don't want to see a thunk allocation for the insertBy expression after CorePrep. -test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) +# Unfortunately, this test is no longer broken after we made workers strict in strict fields, +# so it is no longer a reproducer for T21392. Still, it doesn't hurt if we test that we don't +# regress again. +test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]') ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O']) test('T21801', normal, compile, ['-O -dcore-lint']) test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec']) ===================================== testsuite/tests/simplStg/should_compile/inferTags002.stderr ===================================== @@ -1,88 +1,30 @@ -==================== Output Cmm ==================== -[M.$WMkT_entry() { // [R3, R2] - { info_tbls: [(cym, - label: block_cym_info - rep: StackRep [False] - srt: Nothing), - (cyp, - label: M.$WMkT_info - rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } - srt: Nothing), - (cys, - label: block_cys_info - rep: StackRep [False] - srt: Nothing)] - stack_info: arg_space: 8 - } - {offset - cyp: // global - if ((Sp + -16) < SpLim) (likely: False) goto cyv; else goto cyw; - cyv: // global - R1 = M.$WMkT_closure; - call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - cyw: // global - I64[Sp - 16] = cym; - R1 = R2; - P64[Sp - 8] = R3; - Sp = Sp - 16; - if (R1 & 7 != 0) goto cym; else goto cyn; - cyn: // global - call (I64[R1])(R1) returns to cym, args: 8, res: 8, upd: 8; - cym: // global - I64[Sp] = cys; - _sy8::P64 = R1; - R1 = P64[Sp + 8]; - P64[Sp + 8] = _sy8::P64; - call stg_ap_0_fast(R1) returns to cys, args: 8, res: 8, upd: 8; - cys: // global - Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto cyA; else goto cyz; - cyA: // global - HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cys, args: 8, res: 8, upd: 8; - cyz: // global - I64[Hp - 16] = M.MkT_con_info; - P64[Hp - 8] = P64[Sp + 8]; - P64[Hp] = R1; - R1 = Hp - 15; - Sp = Sp + 16; - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; - } - }, - section ""data" . M.$WMkT_closure" { - M.$WMkT_closure: - const M.$WMkT_info; - }] - - - ==================== Output Cmm ==================== [M.f_entry() { // [R2] - { info_tbls: [(cyK, - label: block_cyK_info + { info_tbls: [(cAs, + label: block_info rep: StackRep [] srt: Nothing), - (cyN, + (cAv, label: M.f_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cyN: // global - if ((Sp + -8) < SpLim) (likely: False) goto cyO; else goto cyP; - cyO: // global + _lbl_: // global + if ((Sp + -8) < SpLim) (likely: False) goto cAw; else goto cAx; + _lbl_: // global R1 = M.f_closure; call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - cyP: // global - I64[Sp - 8] = cyK; + _lbl_: // global + I64[Sp - 8] = cAs; R1 = R2; Sp = Sp - 8; - if (R1 & 7 != 0) goto cyK; else goto cyL; - cyL: // global - call (I64[R1])(R1) returns to cyK, args: 8, res: 8, upd: 8; - cyK: // global + if (R1 & 7 != 0) goto cAs; else goto cAt; + _lbl_: // global + call (I64[R1])(R1) returns to cAs, args: 8, res: 8, upd: 8; + _lbl_: // global R1 = P64[R1 + 15]; Sp = Sp + 8; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; @@ -97,47 +39,47 @@ ==================== Output Cmm ==================== [M.MkT_entry() { // [R3, R2] - { info_tbls: [(cz1, - label: block_cz1_info + { info_tbls: [(cAJ, + label: block_info rep: StackRep [False] srt: Nothing), - (cz4, + (cAM, label: M.MkT_info rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } srt: Nothing), - (cz7, - label: block_cz7_info + (cAP, + label: block_info rep: StackRep [False] srt: Nothing)] stack_info: arg_space: 8 } {offset - cz4: // global - if ((Sp + -16) < SpLim) (likely: False) goto cza; else goto czb; - cza: // global + _lbl_: // global + if ((Sp + -16) < SpLim) (likely: False) goto cAS; else goto cAT; + _lbl_: // global R1 = M.MkT_closure; call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - czb: // global - I64[Sp - 16] = cz1; + _lbl_: // global + I64[Sp - 16] = cAJ; R1 = R2; P64[Sp - 8] = R3; Sp = Sp - 16; - if (R1 & 7 != 0) goto cz1; else goto cz2; - cz2: // global - call (I64[R1])(R1) returns to cz1, args: 8, res: 8, upd: 8; - cz1: // global - I64[Sp] = cz7; - _tyf::P64 = R1; + if (R1 & 7 != 0) goto cAJ; else goto cAK; + _lbl_: // global + call (I64[R1])(R1) returns to cAJ, args: 8, res: 8, upd: 8; + _lbl_: // global + I64[Sp] = cAP; + __locVar_::P64 = R1; R1 = P64[Sp + 8]; - P64[Sp + 8] = _tyf::P64; - call stg_ap_0_fast(R1) returns to cz7, args: 8, res: 8, upd: 8; - cz7: // global + P64[Sp + 8] = __locVar_::P64; + call stg_ap_0_fast(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto czf; else goto cze; - czf: // global + if (Hp > HpLim) (likely: False) goto cAX; else goto cAW; + _lbl_: // global HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cz7, args: 8, res: 8, upd: 8; - cze: // global + call stg_gc_unpt_r1(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global I64[Hp - 16] = M.MkT_con_info; P64[Hp - 8] = P64[Sp + 8]; P64[Hp] = R1; @@ -155,14 +97,14 @@ ==================== Output Cmm ==================== [M.MkT_con_entry() { // [] - { info_tbls: [(czl, + { info_tbls: [(cB3, label: M.MkT_con_info rep: HeapRep 2 ptrs { Con {tag: 0 descr:"main:M.MkT"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - czl: // global + _lbl_: // global R1 = R1 + 1; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } ===================================== testsuite/tests/stranal/sigs/T16859.stderr ===================================== @@ -4,7 +4,7 @@ T16859.bar: <1!A> T16859.baz: <1L><1!P(L)><1C(1,L)> T16859.buz: <1!P(L,L)> T16859.foo: <1L> -T16859.mkInternalName: <1!P(L)><1L><1L> +T16859.mkInternalName: <1!P(L)> T16859.n_loc: <1!P(A,A,A,1L)> T16859.n_occ: <1!P(A,1!P(L,L),A,A)> T16859.n_sort: <1!P(1L,A,A,A)> View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a329a3e86d23110bdee814633a41048e8997f37 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a329a3e86d23110bdee814633a41048e8997f37 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 Dec 8 16:26:38 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Fri, 08 Dec 2023 11:26:38 -0500 Subject: [Git][ghc/ghc][wip/int-index/forall-keyword] 17 commits: Only exit ghci in -e mode when :add command fails Message-ID: <657343be43b03_3478bcf7d05c821378e@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/forall-keyword at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 9140f7bb by Vladislav Zavialov at 2023-12-08T18:29:13+03: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. - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cb4ddb5c72684431d0f570c71f81224bd7065b4...9140f7bbfc636c4a53833de8d9c0dc1a53d08fcb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4cb4ddb5c72684431d0f570c71f81224bd7065b4...9140f7bbfc636c4a53833de8d9c0dc1a53d08fcb 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 Dec 8 17:29:26 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Fri, 08 Dec 2023 12:29:26 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/ghc2021ghc Message-ID: <65735276e3d1e_3478bc10d380282281de@gitlab.mail> Oleg Grenrus pushed new branch wip/ghc2021ghc at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ghc2021ghc 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 Dec 8 17:48:18 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Fri, 08 Dec 2023 12:48:18 -0500 Subject: [Git][ghc/ghc][wip/simplifier-tweaks] 68 commits: JS: clean up some foreign imports Message-ID: <657356e24c2aa_3478bc1196033c231032@gitlab.mail> Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 7bc07cbe by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Several improvements to the handling of coercions * Make `mkSymCo` and `mkInstCo` smarter Fixes #23642 * Fix return role of `SelCo` in the coercion optimiser. Fixes #23617 * Make the coercion optimiser `opt_trans_rule` work better for newtypes Fixes #23619 - - - - - f4df2696 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Simplifier improvements This MR started as: allow the simplifer to do more in one pass, arising from places I could see the simplifier taking two iterations where one would do. But it turned into a larger project, because these changes unexpectedly made inlining blow up, especially join points in deeply-nested cases. The net result is good: a 2% improvement in compile time. The table below shows changes over 1%. The main changes are: * The SimplEnv now has a seInlineDepth field, which says how deep in unfoldings we are. See Note [Inline depth] in Simplify.Env * Avoid repeatedly simplifying coercions. see Note [Avoid re-simplifying coercions] in Simplify.Iteration As you'll see from the Note, this makes use of the seInlineDepth. * Allow Simplify.Utils.postInlineUnconditionally to inline variables that are used exactly once. See Note [Post-inline for single-use things]. * Allow Simplify.Iteration.simplAuxBind to inline used-once things. This is another part of Note [Post-inline for single-use things], and is really good for reducing simplifier iterations in situations like case K e of { K x -> blah } wher x is used once in blah. * Make GHC.Core.SimpleOpt.exprIsConApp_maybe do some simple case elimination. Note [Case elim in exprIsConApp_maybe] * When making join points, don't do so if the join point is so small it will immediately be inlined. See Note [Duplicating alternatives] * Do not add an unfolding to a join point at birth. This is a tricky one and has a long Note [Do not add unfoldings to join points at birth] It shows up in two places - In `mkDupableAlt` do not add an inlining - (trickier) In `simplLetUnfolding` don't add an unfolding for a fresh join point I am not fully satisifed with this, but it works and is well documented. * Many new or rewritten Notes. E.g. Note [Avoiding simplifying repeatedly] I discovered that GHC.HsToCore.Pmc.Solver.Types.trvVarInfo was very delicately balanced. It's a small, heavily used, overloaded function and it's important that it inlines. By a fluke it was before, but at various times in my journey it stopped doing so. So I added an INLINE pragma to it. Metrics: compile_time/bytes allocated ------------------------------------------------ CoOpt_Singletons(normal) -4.3% GOOD LargeRecord(normal) -23.3% GOOD PmSeriesS(normal) -2.4% T11195(normal) -1.7% T12227(normal) -20.0% GOOD T12545(normal) -5.4% T13253-spj(normal) -50.7% GOOD T13386(normal) -5.1% GOOD T14766(normal) -2.4% GOOD T15164(normal) -1.7% T15304(normal) +1.0% T15630(normal) -7.7% T15630a(normal) NEW T15703(normal) -7.5% GOOD T16577(normal) -5.1% GOOD T17516(normal) -3.6% T18223(normal) -16.8% GOOD T18282(normal) -1.5% T18304(normal) +1.9% T21839c(normal) -3.5% GOOD T3064(normal) -1.5% T5030(normal) -16.2% GOOD T5321Fun(normal) -1.6% T6048(optasm) -2.1% GOOD T8095(normal) -6.1% GOOD T9630(normal) -5.1% GOOD WWRec(normal) -1.6% geo. mean -2.1% minimum -50.7% maximum +1.9% Metric Decrease: CoOpt_Singletons LargeRecord T12227 T13253-spj T13386 T14766 T15703 T16577 T18223 T21839c T5030 T6048 T8095 T9630 - - - - - fe0ed3df by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Improve postInlineUnconditionally This commit adds two things to postInlineUnconditionally: 1. Do not postInlineUnconditionally join point, ever. Doing so does not reduce allocation, which is the main point, and with join points that are used a lot it can bloat code. See point (1) of Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration. 2. Do not postInlineUnconditionally a strict (demanded) binding. It will not allocate a thunk (it'll turn into a case instead) so again the main point of inlining it doesn't hold. Better to check per-call-site. - - - - - 6e023d30 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Update testsuite output - - - - - 58c29d08 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Try effect of * making multi-branch cases not work free (fixes #22423) * use plan A for dataToTag and tagToEnum - - - - - 8264837a by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 More changes * No floating at all for join points * Never inline j x = I x Example: integerSignum !j = IS (integerSignum# j) We want this to inline and then cancel with an enclosing case. But it won't if we have changed it to integerSignum x = case x of IN a -> IS (...) IS b -> IS (...) IP c -> IS (...) This involved changing - UnfoldingGuidance to not say always-inline for j x = Ix - callSiteInline to inline join points only if there is a real benefit - ok_to_dup_alt in Simplify.Iteration * Row back (for now) on changes to GHC.Core.Utils.ExprIsCheap - - - - - 9f1e9f1a by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Wibble - - - - - 1776bcb4 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Wibble - - - - - 3d13de65 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Further wibbles - - - - - 37c16e51 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 One more wibble Don't float an unlifted join point - - - - - 88ac5238 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Small wibbles The most significant change is to mkSelCo. - - - - - d041c77f by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Temporarily add -DDEBUG to Coercion.hs - - - - - cd5b7209 by Simon Peyton Jones at 2023-12-08T12:00:41+00:00 Fix a missing zonk in before mkSelCo - - - - - ab9532ca by Simon Peyton Jones at 2023-12-08T12:01:53+00:00 Wibbles - - - - - 952576b0 by Simon Peyton Jones at 2023-12-08T12:01:53+00:00 Tickish comment - - - - - 30 changed files: - .gitlab/merge_request_templates/Default.md - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Inline.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/Stats.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/10e5e6ced5f3186f382c493d685aff51e253e0e9...952576b00b40e70d77ebd92e58e4880b7589db86 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/10e5e6ced5f3186f382c493d685aff51e253e0e9...952576b00b40e70d77ebd92e58e4880b7589db86 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 Dec 8 17:54:14 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 12:54:14 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: Improve duplicate elimination in SpecConstr Message-ID: <657358461841_3478bc11b181ac23399@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 2f13217a by Simon Peyton Jones at 2023-12-08T12:54:09-05:00 Comments only in FloatIn Relevant to #3458 - - - - - 294eb052 by Simon Peyton Jones at 2023-12-08T12:54:09-05:00 Comments only in SpecConstr - - - - - b4c8371e by Simon Peyton Jones at 2023-12-08T12:54:09-05:00 Add test for #22238 - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Tc/Utils/TcType.hs - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/perf/compiler/all.T - + testsuite/tests/quantified-constraints/T22238.hs - testsuite/tests/quantified-constraints/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b1b7fdae4d5d07939ecd18628438f2495fa90568...b4c8371e581c3c4dd1507ab0631d665efa60828b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b1b7fdae4d5d07939ecd18628438f2495fa90568...b4c8371e581c3c4dd1507ab0631d665efa60828b 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 Dec 8 19:19:31 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Fri, 08 Dec 2023 14:19:31 -0500 Subject: [Git][ghc/ghc][wip/T23478] 17 commits: Only exit ghci in -e mode when :add command fails Message-ID: <65736c4353f00_3478bc13d07114240621@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 1749128a by Oleg Grenrus at 2023-12-08T21:19:19+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Errors/Types/PromotionErr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Error/Codes.hs - compiler/Language/Haskell/Syntax/Expr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a8d3c5178171a89e61ba145b166dc072df4328b...1749128a476bba2a513980e296ba261188f3c6a2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a8d3c5178171a89e61ba145b166dc072df4328b...1749128a476bba2a513980e296ba261188f3c6a2 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 Dec 8 19:20:55 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Fri, 08 Dec 2023 14:20:55 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/int-index/rta-docs Message-ID: <65736c97eabd3_3478bc13b5cc882426a7@gitlab.mail> Vladislav Zavialov pushed new branch wip/int-index/rta-docs at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/rta-docs 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 Dec 8 19:23:26 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Fri, 08 Dec 2023 14:23:26 -0500 Subject: [Git][ghc/ghc][wip/T23478] Move definitions of SNat, SChar and SSymbol to ghc-internal Message-ID: <65736d2e44719_3478bc13d07114244494@gitlab.mail> Oleg Grenrus pushed to branch wip/T23478 at Glasgow Haskell Compiler / GHC Commits: 413e4e47 by Oleg Grenrus at 2023-12-08T21:23:14+02:00 Move definitions of SNat, SChar and SSymbol to ghc-internal ... and expose their constructors there - - - - - 12 changed files: - libraries/base/src/GHC/TypeLits.hs - libraries/base/src/GHC/TypeNats.hs - libraries/ghc-internal/ghc-internal.cabal - − libraries/ghc-internal/src/Dummy.hs - + libraries/ghc-internal/src/GHC/Internal/TypeLits.hs - + libraries/ghc-internal/src/GHC/Internal/TypeNats.hs - testsuite/tests/ghci/scripts/T9181.stdout - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/plugins/plugins09.stdout - testsuite/tests/plugins/plugins10.stdout - testsuite/tests/plugins/plugins11.stdout - testsuite/tests/plugins/static-plugins.stdout Changes: ===================================== libraries/base/src/GHC/TypeLits.hs ===================================== @@ -17,6 +17,9 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SChar and SSymbol +{-# OPTIONS_GHC -Wno-orphans #-} + {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the @@ -69,7 +72,7 @@ module GHC.TypeLits ) where -import GHC.Base ( Bool(..), Eq(..), Functor(..), Ord(..), Ordering(..), String +import GHC.Base ( Eq(..), Functor(..), Ord(..), Ordering(..), String , (.), otherwise, withDict, Void, (++) , errorWithoutStackTrace) import GHC.Types(Symbol, Char, TYPE) @@ -90,6 +93,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeLits.Internal(CmpSymbol, CmpChar) import qualified GHC.TypeNats as N +import GHC.Internal.TypeLits + -------------------------------------------------------------------------------- -- | This class gives the string associated with a type-level symbol. @@ -325,24 +330,6 @@ withSomeSNat n k | n >= 0 = N.withSomeSNat (fromInteger n) (\sn -> k (Just sn)) | otherwise = k Nothing --- | A value-level witness for a type-level symbol. This is commonly referred --- to as a /singleton/ type, as for each @s@, there is a single value that --- inhabits the type @'SSymbol' s@ (aside from bottom). --- --- The definition of 'SSymbol' is intentionally left abstract. To obtain an --- 'SSymbol' value, use one of the following: --- --- 1. The 'symbolSing' method of 'KnownSymbol'. --- --- 2. The @SSymbol@ pattern synonym. --- --- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a --- 'String'. --- --- @since 4.18.0.0 -newtype SSymbol (s :: Symbol) = UnsafeSSymbol String -type role SSymbol nominal - -- | A explicitly bidirectional pattern synonym relating an 'SSymbol' to a -- 'KnownSymbol' constraint. -- @@ -377,14 +364,6 @@ data KnownSymbolInstance (s :: Symbol) where knownSymbolInstance :: SSymbol s -> KnownSymbolInstance s knownSymbolInstance ss = withKnownSymbol ss KnownSymbolInstance --- | @since 4.19.0.0 -instance Eq (SSymbol s) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SSymbol s) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SSymbol s) where showsPrec p (UnsafeSSymbol s) @@ -429,22 +408,7 @@ withSomeSSymbol s k = k (UnsafeSSymbol s) -- For details see Note [NOINLINE withSomeSNat] in "GHC.TypeNats" -- The issue described there applies to `withSomeSSymbol` as well. --- | A value-level witness for a type-level character. This is commonly referred --- to as a /singleton/ type, as for each @c@, there is a single value that --- inhabits the type @'SChar' c@ (aside from bottom). --- --- The definition of 'SChar' is intentionally left abstract. To obtain an --- 'SChar' value, use one of the following: --- --- 1. The 'charSing' method of 'KnownChar'. --- --- 2. The @SChar@ pattern synonym. --- --- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. --- --- @since 4.18.0.0 -newtype SChar (s :: Char) = UnsafeSChar Char -type role SChar nominal + -- | A explicitly bidirectional pattern synonym relating an 'SChar' to a -- 'KnownChar' constraint. @@ -480,14 +444,6 @@ data KnownCharInstance (n :: Char) where knownCharInstance :: SChar c -> KnownCharInstance c knownCharInstance sc = withKnownChar sc KnownCharInstance --- | @since 4.19.0.0 -instance Eq (SChar c) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SChar c) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SChar c) where showsPrec p (UnsafeSChar c) ===================================== libraries/base/src/GHC/TypeNats.hs ===================================== @@ -18,6 +18,9 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} +-- orphan instances for SNat +{-# OPTIONS_GHC -Wno-orphans #-} + {-| This module is an internal GHC module. It declares the constants used in the implementation of type-level natural numbers. The programmer interface for working with type-level naturals should be defined in a separate library. @@ -67,6 +70,8 @@ import Unsafe.Coerce(unsafeCoerce) import GHC.TypeNats.Internal(CmpNat) +import GHC.Internal.TypeNats + -- | A type synonym for 'Natural'. -- -- Previously, this was an opaque data type, but it was changed to a type @@ -329,23 +334,7 @@ cmpNat x y = case compare (natVal x) (natVal y) of -------------------------------------------------------------------------------- -- Singleton values --- | A value-level witness for a type-level natural number. This is commonly --- referred to as a /singleton/ type, as for each @n@, there is a single value --- that inhabits the type @'SNat' n@ (aside from bottom). --- --- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' --- value, use one of the following: --- --- 1. The 'natSing' method of 'KnownNat'. --- --- 2. The @SNat@ pattern synonym. --- --- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' --- number. --- --- @since 4.18.0.0 -newtype SNat (n :: Nat) = UnsafeSNat Natural -type role SNat nominal + -- | A explicitly bidirectional pattern synonym relating an 'SNat' to a -- 'KnownNat' constraint. @@ -381,14 +370,6 @@ data KnownNatInstance (n :: Nat) where knownNatInstance :: SNat n -> KnownNatInstance n knownNatInstance sn = withKnownNat sn KnownNatInstance --- | @since 4.19.0.0 -instance Eq (SNat n) where - _ == _ = True - --- | @since 4.19.0.0 -instance Ord (SNat n) where - compare _ _ = EQ - -- | @since 4.18.0.0 instance Show (SNat n) where showsPrec p (UnsafeSNat n) ===================================== libraries/ghc-internal/ghc-internal.cabal ===================================== @@ -23,9 +23,10 @@ common warnings library import: warnings + exposed-modules: - other-modules: Dummy - other-extensions: + GHC.Internal.TypeLits + GHC.Internal.TypeNats build-depends: rts == 1.0.*, ghc-prim >= 0.5.1.0 && < 0.11, ghc-bignum >= 1.0 && < 2.0 ===================================== libraries/ghc-internal/src/Dummy.hs deleted ===================================== @@ -1,11 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - --- | This module merely serves as a placeholder since --- Haskell packages must contain at least one module. --- This can be dropped once a real module has been introduced to --- @ghc-internal at . -module Dummy () where - --- for build system dependency ordering -import GHC.Types () -import GHC.Num.BigNat () ===================================== libraries/ghc-internal/src/GHC/Internal/TypeLits.hs ===================================== @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE PatternSynonyms #-} +module GHC.Internal.TypeLits ( + SChar (UnsafeSChar), + SSymbol (UnsafeSSymbol), +) where + +import GHC.Types (Char, Symbol, Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level character. This is commonly referred +-- to as a /singleton/ type, as for each @c@, there is a single value that +-- inhabits the type @'SChar' c@ (aside from bottom). +-- +-- The definition of 'SChar' is intentionally left abstract. To obtain an +-- 'SChar' value, use one of the following: +-- +-- 1. The 'charSing' method of 'KnownChar'. +-- +-- 2. The @SChar@ pattern synonym. +-- +-- 3. The 'withSomeSChar' function, which creates an 'SChar' from a 'Char'. +-- +-- /since base-4.18.0.0/ +newtype SChar (s :: Char) = UnsafeSChar_ Char +type role SChar nominal + +-- See Note [SNat constructor] in GHC.Internal.TypeNats +pattern UnsafeSChar :: Char -> SChar n +pattern UnsafeSChar c = UnsafeSChar_ c +{-# COMPLETE UnsafeSChar #-} + +-- | /since base-4.19.0.0/ +instance Eq (SChar c) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SChar c) where + compare _ _ = EQ + +-- | A value-level witness for a type-level symbol. This is commonly referred +-- to as a /singleton/ type, as for each @s@, there is a single value that +-- inhabits the type @'SSymbol' s@ (aside from bottom). +-- +-- The definition of 'SSymbol' is intentionally left abstract. To obtain an +-- 'SSymbol' value, use one of the following: +-- +-- 1. The 'symbolSing' method of 'KnownSymbol'. +-- +-- 2. The @SSymbol@ pattern synonym. +-- +-- 3. The 'withSomeSSymbol' function, which creates an 'SSymbol' from a +-- 'String'. +-- +-- /since base-4.18.0.0/ +newtype SSymbol (s :: Symbol) = UnsafeSSymbol_ [Char] +type role SSymbol nominal + +-- See Note [SNat constructor] in GHC.Internal.TypeNats +pattern UnsafeSSymbol :: [Char] -> SSymbol n +pattern UnsafeSSymbol s = UnsafeSSymbol_ s +{-# COMPLETE UnsafeSSymbol #-} + +-- | /since base-4.19.0.0/ +instance Eq (SSymbol s) where + _ == _ = True + +-- | /since base-4.19.0.0/ +instance Ord (SSymbol s) where + compare _ _ = EQ ===================================== libraries/ghc-internal/src/GHC/Internal/TypeNats.hs ===================================== @@ -0,0 +1,55 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE PatternSynonyms #-} +module GHC.Internal.TypeNats ( + SNat (UnsafeSNat), +)where + +import GHC.Num.Natural(Natural) +import GHC.Types (Bool (..), Ordering (..)) +import GHC.Classes (Eq (..), Ord (..)) +import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer] in GHC.Base + +-- | A value-level witness for a type-level natural number. This is commonly +-- referred to as a /singleton/ type, as for each @n@, there is a single value +-- that inhabits the type @'SNat' n@ (aside from bottom). +-- +-- The definition of 'SNat' is intentionally left abstract. To obtain an 'SNat' +-- value, use one of the following: +-- +-- 1. The 'natSing' method of 'KnownNat'. +-- +-- 2. The @SNat@ pattern synonym. +-- +-- 3. The 'withSomeSNat' function, which creates an 'SNat' from a 'Natural' +-- number. +-- +-- /since base-4.18.0.0/ +-- +newtype SNat (n :: Natural) = UnsafeSNat_ Natural +type role SNat nominal + +-- See Note [SNat constructor] +pattern UnsafeSNat :: Natural -> SNat n +pattern UnsafeSNat n = UnsafeSNat_ n +{-# COMPLETE UnsafeSNat #-} + +-- | /since base-4.19.0.0/ +instance Eq (SNat n) where + _ == _ = True + +-- | /since 4.19.0.0/ +instance Ord (SNat n) where + compare _ _ = EQ + +{- +Note [SNat constructor] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a concern raised that having the real constructor of SNat exposed may +allow accidental 'coerce'. To avoid that, we define a pattern synonym. It +looks like real constructor, but prevents from coercing SNats when +(pseudo)constructor is in scope. + +-} ===================================== testsuite/tests/ghci/scripts/T9181.stdout ===================================== @@ -8,24 +8,20 @@ type GHC.TypeLits.ConsSymbol :: Char type family GHC.TypeLits.ConsSymbol a b type GHC.TypeLits.KnownChar :: Char -> Constraint class GHC.TypeLits.KnownChar n where - GHC.TypeLits.charSing :: GHC.TypeLits.SChar n + GHC.TypeLits.charSing :: GHC.Internal.TypeLits.SChar n {-# MINIMAL charSing #-} type GHC.TypeLits.KnownSymbol :: GHC.Types.Symbol -> Constraint class GHC.TypeLits.KnownSymbol n where - GHC.TypeLits.symbolSing :: GHC.TypeLits.SSymbol n + GHC.TypeLits.symbolSing :: GHC.Internal.TypeLits.SSymbol n {-# MINIMAL symbolSing #-} type GHC.TypeLits.NatToChar :: GHC.Num.Natural.Natural -> Char type family GHC.TypeLits.NatToChar a pattern GHC.TypeLits.SChar - :: () => GHC.TypeLits.KnownChar c => GHC.TypeLits.SChar c -type role GHC.TypeLits.SChar nominal -type GHC.TypeLits.SChar :: Char -> * -newtype GHC.TypeLits.SChar s = GHC.TypeLits.UnsafeSChar Char + :: () => GHC.TypeLits.KnownChar c => GHC.Internal.TypeLits.SChar c pattern GHC.TypeLits.SSymbol - :: () => GHC.TypeLits.KnownSymbol s => GHC.TypeLits.SSymbol s -type role GHC.TypeLits.SSymbol nominal -type GHC.TypeLits.SSymbol :: GHC.Types.Symbol -> * -newtype GHC.TypeLits.SSymbol s = GHC.TypeLits.UnsafeSSymbol String + :: () => + GHC.TypeLits.KnownSymbol s => + GHC.Internal.TypeLits.SSymbol s type GHC.TypeLits.SomeChar :: * data GHC.TypeLits.SomeChar = forall (n :: Char). @@ -62,9 +58,10 @@ GHC.TypeLits.decideSymbol :: -> Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) -GHC.TypeLits.fromSChar :: GHC.TypeLits.SChar c -> Char -GHC.TypeLits.fromSNat :: GHC.TypeNats.SNat n -> Integer -GHC.TypeLits.fromSSymbol :: GHC.TypeLits.SSymbol s -> String +GHC.TypeLits.fromSChar :: GHC.Internal.TypeLits.SChar c -> Char +GHC.TypeLits.fromSNat :: GHC.Internal.TypeNats.SNat n -> Integer +GHC.TypeLits.fromSSymbol :: + GHC.Internal.TypeLits.SSymbol s -> String GHC.TypeLits.natVal :: GHC.TypeNats.KnownNat n => proxy n -> Integer GHC.TypeLits.natVal' :: @@ -83,19 +80,23 @@ GHC.TypeLits.symbolVal :: GHC.TypeLits.symbolVal' :: GHC.TypeLits.KnownSymbol n => GHC.Prim.Proxy# n -> String GHC.TypeLits.withKnownChar :: - GHC.TypeLits.SChar c -> (GHC.TypeLits.KnownChar c => r) -> r + GHC.Internal.TypeLits.SChar c + -> (GHC.TypeLits.KnownChar c => r) -> r GHC.TypeLits.withKnownSymbol :: - GHC.TypeLits.SSymbol s -> (GHC.TypeLits.KnownSymbol s => r) -> r + GHC.Internal.TypeLits.SSymbol s + -> (GHC.TypeLits.KnownSymbol s => r) -> r GHC.TypeLits.withSomeSChar :: - Char -> (forall (c :: Char). GHC.TypeLits.SChar c -> r) -> r + Char + -> (forall (c :: Char). GHC.Internal.TypeLits.SChar c -> r) -> r GHC.TypeLits.withSomeSNat :: Integer - -> (forall (n :: GHC.TypeNats.Nat). - Maybe (GHC.TypeNats.SNat n) -> r) + -> (forall (n :: GHC.Num.Natural.Natural). + Maybe (GHC.Internal.TypeNats.SNat n) -> r) -> r GHC.TypeLits.withSomeSSymbol :: String - -> (forall (s :: GHC.Types.Symbol). GHC.TypeLits.SSymbol s -> r) + -> (forall (s :: GHC.Types.Symbol). + GHC.Internal.TypeLits.SSymbol s -> r) -> r type (GHC.TypeNats.*) :: GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural @@ -138,7 +139,7 @@ data GHC.TypeError.ErrorMessage GHC.TypeError.ErrorMessage type GHC.TypeNats.KnownNat :: GHC.TypeNats.Nat -> Constraint class GHC.TypeNats.KnownNat n where - GHC.TypeNats.natSing :: GHC.TypeNats.SNat n + GHC.TypeNats.natSing :: GHC.Internal.TypeNats.SNat n {-# MINIMAL natSing #-} type GHC.TypeNats.Log2 :: GHC.Num.Natural.Natural -> GHC.Num.Natural.Natural @@ -164,12 +165,20 @@ data Data.Type.Ord.OrderingI a b where Data.Type.Ord.GTI :: forall {k} (a :: k) (b :: k). (Data.Type.Ord.Compare a b ~ GT) => Data.Type.Ord.OrderingI a b +type role GHC.Internal.TypeLits.SChar nominal +type GHC.Internal.TypeLits.SChar :: Char -> * +newtype GHC.Internal.TypeLits.SChar s + = GHC.Internal.TypeLits.UnsafeSChar_ Char pattern GHC.TypeNats.SNat - :: () => GHC.TypeNats.KnownNat n => GHC.TypeNats.SNat n -type role GHC.TypeNats.SNat nominal -type GHC.TypeNats.SNat :: GHC.TypeNats.Nat -> * -newtype GHC.TypeNats.SNat n - = GHC.TypeNats.UnsafeSNat GHC.Num.Natural.Natural + :: () => GHC.TypeNats.KnownNat n => GHC.Internal.TypeNats.SNat n +type role GHC.Internal.TypeNats.SNat nominal +type GHC.Internal.TypeNats.SNat :: GHC.Num.Natural.Natural -> * +newtype GHC.Internal.TypeNats.SNat n + = GHC.Internal.TypeNats.UnsafeSNat_ GHC.Num.Natural.Natural +type role GHC.Internal.TypeLits.SSymbol nominal +type GHC.Internal.TypeLits.SSymbol :: GHC.Types.Symbol -> * +newtype GHC.Internal.TypeLits.SSymbol s + = GHC.Internal.TypeLits.UnsafeSSymbol_ [Char] type GHC.TypeNats.SomeNat :: * data GHC.TypeNats.SomeNat = forall (n :: GHC.TypeNats.Nat). @@ -197,4 +206,4 @@ GHC.TypeNats.sameNat :: (GHC.TypeNats.KnownNat a, GHC.TypeNats.KnownNat b) => proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) GHC.TypeNats.withKnownNat :: - GHC.TypeNats.SNat n -> (GHC.TypeNats.KnownNat n => r) -> r + GHC.Internal.TypeNats.SNat n -> (GHC.TypeNats.KnownNat n => r) -> r ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -9462,7 +9462,7 @@ module GHC.TypeLits where newtype SChar s = ... pattern SNat :: forall (n :: Nat). () => KnownNat n => SNat n type role SNat nominal - type SNat :: Nat -> * + type SNat :: Natural -> * newtype SNat n = ... pattern SSymbol :: forall (s :: Symbol). () => KnownSymbol s => SSymbol s type role SSymbol nominal @@ -9491,7 +9491,7 @@ module GHC.TypeLits where decideNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) decideSymbol :: forall (a :: Symbol) (b :: Symbol) (proxy1 :: Symbol -> *) (proxy2 :: Symbol -> *). (KnownSymbol a, KnownSymbol b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) fromSChar :: forall (c :: GHC.Types.Char). SChar c -> GHC.Types.Char - fromSNat :: forall (n :: Nat). SNat n -> GHC.Num.Integer.Integer + fromSNat :: forall (n :: Natural). SNat n -> GHC.Num.Integer.Integer fromSSymbol :: forall (s :: Symbol). SSymbol s -> GHC.Base.String natVal :: forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> GHC.Num.Integer.Integer natVal' :: forall (n :: Nat). KnownNat n => GHC.Prim.Proxy# n -> GHC.Num.Integer.Integer @@ -9504,10 +9504,10 @@ module GHC.TypeLits where symbolVal :: forall (n :: Symbol) (proxy :: Symbol -> *). KnownSymbol n => proxy n -> GHC.Base.String symbolVal' :: forall (n :: Symbol). KnownSymbol n => GHC.Prim.Proxy# n -> GHC.Base.String withKnownChar :: forall (c :: GHC.Types.Char) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SChar c -> (KnownChar c => r) -> r - withKnownNat :: forall (n :: Nat) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r + withKnownNat :: forall (n :: Natural) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withKnownSymbol :: forall (s :: Symbol) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SSymbol s -> (KnownSymbol s => r) -> r withSomeSChar :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Types.Char -> (forall (c :: GHC.Types.Char). SChar c -> r) -> r - withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Num.Integer.Integer -> (forall (n :: Nat). GHC.Maybe.Maybe (SNat n) -> r) -> r + withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Num.Integer.Integer -> (forall (n :: Natural). GHC.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). GHC.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r module GHC.TypeLits.Internal where @@ -9549,7 +9549,7 @@ module GHC.TypeNats where data Natural = ... pattern SNat :: forall (n :: Nat). () => KnownNat n => SNat n type role SNat nominal - type SNat :: Nat -> * + type SNat :: Natural -> * newtype SNat n = ... type SomeNat :: * data SomeNat = forall (n :: Nat). KnownNat n => SomeNat (Data.Proxy.Proxy n) @@ -9557,13 +9557,13 @@ module GHC.TypeNats where type family (^) a b cmpNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Type.Ord.OrderingI a b decideNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> Data.Either.Either ((a Data.Type.Equality.:~: b) -> GHC.Base.Void) (a Data.Type.Equality.:~: b) - fromSNat :: forall (n :: Nat). SNat n -> Natural + fromSNat :: forall (n :: Natural). SNat n -> Natural natVal :: forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Natural natVal' :: forall (n :: Nat). KnownNat n => GHC.Prim.Proxy# n -> Natural sameNat :: forall (a :: Nat) (b :: Nat) (proxy1 :: Nat -> *) (proxy2 :: Nat -> *). (KnownNat a, KnownNat b) => proxy1 a -> proxy2 b -> GHC.Maybe.Maybe (a Data.Type.Equality.:~: b) someNatVal :: Natural -> SomeNat - withKnownNat :: forall (n :: Nat) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r - withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r + withKnownNat :: forall (n :: Natural) (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r + withSomeSNat :: forall (rep :: GHC.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Natural). SNat n -> r) -> r module GHC.TypeNats.Internal where -- Safety: Trustworthy @@ -11014,15 +11014,15 @@ instance Data.Traversable.Traversable Data.Semigroup.First -- Defined in ‘Data instance Data.Traversable.Traversable Data.Semigroup.Last -- Defined in ‘Data.Semigroup’ instance Data.Traversable.Traversable Data.Semigroup.Max -- Defined in ‘Data.Semigroup’ instance Data.Traversable.Traversable Data.Semigroup.Min -- Defined in ‘Data.Semigroup’ -instance Data.Type.Coercion.TestCoercion GHC.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Coercion.TestCoercion GHC.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Coercion.TestCoercion GHC.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ +instance Data.Type.Coercion.TestCoercion GHC.Internal.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Coercion.TestCoercion GHC.Internal.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Coercion.TestCoercion GHC.Internal.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ instance forall k (a :: k). Data.Type.Coercion.TestCoercion ((Data.Type.Equality.:~:) a) -- Defined in ‘Data.Type.Coercion’ instance forall k1 k (a :: k1). Data.Type.Coercion.TestCoercion ((Data.Type.Equality.:~~:) a) -- Defined in ‘Data.Type.Coercion’ instance forall k (a :: k). Data.Type.Coercion.TestCoercion (Data.Type.Coercion.Coercion a) -- Defined in ‘Data.Type.Coercion’ -instance Data.Type.Equality.TestEquality GHC.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Equality.TestEquality GHC.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ -instance Data.Type.Equality.TestEquality GHC.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ +instance Data.Type.Equality.TestEquality GHC.Internal.TypeLits.SChar -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Equality.TestEquality GHC.Internal.TypeLits.SSymbol -- Defined in ‘GHC.TypeLits’ +instance Data.Type.Equality.TestEquality GHC.Internal.TypeNats.SNat -- Defined in ‘GHC.TypeNats’ instance forall k (a :: k). Data.Type.Equality.TestEquality ((Data.Type.Equality.:~:) a) -- Defined in ‘Data.Type.Equality’ instance forall k1 k (a :: k1). Data.Type.Equality.TestEquality ((Data.Type.Equality.:~~:) a) -- Defined in ‘Data.Type.Equality’ instance forall k. Data.Type.Equality.TestEquality base-4.19.0.0:Data.Typeable.Internal.TypeRep -- Defined in ‘base-4.19.0.0:Data.Typeable.Internal’ @@ -12076,11 +12076,11 @@ instance GHC.Show.Show GHC.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Stac instance GHC.Show.Show GHC.StaticPtr.StaticPtrInfo -- Defined in ‘GHC.StaticPtr’ instance GHC.Show.Show GHC.Stats.GCDetails -- Defined in ‘GHC.Stats’ instance GHC.Show.Show GHC.Stats.RTSStats -- Defined in ‘GHC.Stats’ -instance forall (c :: GHC.Types.Char). GHC.Show.Show (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Show.Show (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ +instance forall (c :: GHC.Types.Char). GHC.Show.Show (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ +instance forall (s :: GHC.Types.Symbol). GHC.Show.Show (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Show.Show GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Show.Show GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Show.Show (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Show.Show (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Show.Show GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ instance [safe] GHC.Show.Show System.Timeout.Timeout -- Defined in ‘System.Timeout’ instance GHC.Show.Show Text.Read.Lex.Lexeme -- Defined in ‘Text.Read.Lex’ @@ -12267,12 +12267,12 @@ instance GHC.Classes.Eq GHC.Num.BigNat.BigNat -- Defined in ‘GHC.Num.BigNat’ instance GHC.Classes.Eq GHC.Num.Natural.Natural -- Defined in ‘GHC.Num.Natural’ instance forall a. GHC.Classes.Eq (GHC.StableName.StableName a) -- Defined in ‘GHC.StableName’ instance GHC.Classes.Eq GHC.Stack.CloneStack.StackEntry -- Defined in ‘GHC.Stack.CloneStack’ -instance forall (c :: GHC.Types.Char). GHC.Classes.Eq (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Classes.Eq (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Eq GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Eq GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Classes.Eq (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Classes.Eq GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ +instance forall (c :: GHC.Types.Char). GHC.Classes.Eq (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ +instance forall (s :: GHC.Types.Symbol). GHC.Classes.Eq (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Classes.Eq (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ instance [safe] GHC.Classes.Eq System.Timeout.Timeout -- Defined in ‘System.Timeout’ instance GHC.Classes.Eq Text.Read.Lex.Lexeme -- Defined in ‘Text.Read.Lex’ instance GHC.Classes.Eq Text.Read.Lex.Number -- Defined in ‘Text.Read.Lex’ @@ -12394,9 +12394,9 @@ instance GHC.Classes.Ord GHC.IO.IOMode.IOMode -- Defined in ‘GHC.IO.IOMode’ instance GHC.Classes.Ord GHC.Num.Integer.Integer -- Defined in ‘GHC.Num.Integer’ instance GHC.Classes.Ord GHC.Num.BigNat.BigNat -- Defined in ‘GHC.Num.BigNat’ instance GHC.Classes.Ord GHC.Num.Natural.Natural -- Defined in ‘GHC.Num.Natural’ -instance forall (c :: GHC.Types.Char). GHC.Classes.Ord (GHC.TypeLits.SChar c) -- Defined in ‘GHC.TypeLits’ -instance forall (s :: GHC.Types.Symbol). GHC.Classes.Ord (GHC.TypeLits.SSymbol s) -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Ord GHC.TypeLits.SomeChar -- Defined in ‘GHC.TypeLits’ instance GHC.Classes.Ord GHC.TypeLits.SomeSymbol -- Defined in ‘GHC.TypeLits’ -instance forall (n :: GHC.TypeNats.Nat). GHC.Classes.Ord (GHC.TypeNats.SNat n) -- Defined in ‘GHC.TypeNats’ instance GHC.Classes.Ord GHC.TypeNats.SomeNat -- Defined in ‘GHC.TypeNats’ +instance forall (c :: GHC.Types.Char). GHC.Classes.Ord (GHC.Internal.TypeLits.SChar c) -- Defined in ‘GHC.Internal.TypeLits’ +instance forall (s :: GHC.Types.Symbol). GHC.Classes.Ord (GHC.Internal.TypeLits.SSymbol s) -- Defined in ‘GHC.Internal.TypeLits’ +instance forall (n :: GHC.Num.Natural.Natural). GHC.Classes.Ord (GHC.Internal.TypeNats.SNat n) -- Defined in ‘GHC.Internal.TypeNats’ ===================================== testsuite/tests/plugins/plugins09.stdout ===================================== @@ -2,6 +2,8 @@ parsePlugin(a,b) interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) typeCheckPlugin (tc) ===================================== testsuite/tests/plugins/plugins10.stdout ===================================== @@ -4,6 +4,8 @@ interfacePlugin: Language.Haskell.TH interfacePlugin: Language.Haskell.TH.Quote interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext interfacePlugin: Language.Haskell.TH.Syntax typeCheckPlugin (rn) ===================================== testsuite/tests/plugins/plugins11.stdout ===================================== @@ -2,6 +2,8 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext typeCheckPlugin (rn) typeCheckPlugin (tc) ===================================== testsuite/tests/plugins/static-plugins.stdout ===================================== @@ -3,6 +3,8 @@ parsePlugin() interfacePlugin: Prelude interfacePlugin: GHC.Base interfacePlugin: GHC.Float +interfacePlugin: GHC.TypeLits +interfacePlugin: GHC.TypeNats interfacePlugin: GHC.Prim.Ext interfacePlugin: System.IO interfacePlugin: GHC.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/413e4e47c445d4fa3d72b3ccad23fc1b4ae83626 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/413e4e47c445d4fa3d72b3ccad23fc1b4ae83626 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 Dec 8 19:39:25 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Fri, 08 Dec 2023 14:39:25 -0500 Subject: [Git][ghc/ghc][wip/int-index/rta-docs] 9 commits: testsuite: add test for #23944 Message-ID: <657370eddd4f9_3478bc148532fc247943@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/rta-docs at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - f0de3619 by Vladislav Zavialov at 2023-12-08T19:39:23+00: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. - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Tc/Utils/TcType.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - libraries/base/src/GHC/Unicode.hs - + testsuite/tests/cmm/should_compile/T24224.cmm - + testsuite/tests/cmm/should_compile/T24224.stderr - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/driver/T23944.hs - + testsuite/tests/driver/T23944.stderr - + testsuite/tests/driver/T23944A.hs - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T - testsuite/tests/driver/all.T - testsuite/tests/perf/compiler/all.T - + testsuite/tests/simplCore/should_compile/T23209.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d394992684d8a60f1b6818bae5da8aab880f71b...f0de3619b760d7e3768a223dfe9012e4d4c0ce3c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9d394992684d8a60f1b6818bae5da8aab880f71b...f0de3619b760d7e3768a223dfe9012e4d4c0ce3c 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 Dec 8 20:31:11 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 08 Dec 2023 15:31:11 -0500 Subject: [Git][ghc/ghc][wip/sym-type] 93 commits: Add a regression test for #24064 Message-ID: <65737d0f6367f_3478bc154e72e8253876@gitlab.mail> Ben Gamari pushed to branch wip/sym-type at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 94823718 by Ben Gamari at 2023-12-08T15:31:00-05:00 rts/linker: Clearly define SymType Previously SymType was both an enumeration of three symbol types *and* an orthogonal flag (`DUP_DISCARD`, introduced in !9475). This was quite fragile as it meant that to extract the symbol type one had to careful mask out the flag. Naturally this wasn't done consistently. Fix this by renaming the field to `flags` and adding an accessor. Fixes #24117. - - - - - 30 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - 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/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Linker.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a168f39b172d2907011dd7e44d66514745ee100a...948237183807dc2a031fe2200cb310490d92bfe0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a168f39b172d2907011dd7e44d66514745ee100a...948237183807dc2a031fe2200cb310490d92bfe0 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 Dec 8 20:54:47 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 15:54:47 -0500 Subject: [Git][ghc/ghc][master] Take care when simplifying unfoldings Message-ID: <65738297c1b91_3478bc164a51bc2633bb@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 8 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Stg/CSE.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -154,7 +154,7 @@ These data types are the heart of the compiler -- f_1 x_2 = let f_3 x_4 = x_4 + 1 -- in f_3 (x_2 - 2) -- @ --- But see Note [Shadowing] below. +-- But see Note [Shadowing in Core] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating -- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names. @@ -312,26 +312,6 @@ data Bind b = NonRec b (Expr b) deriving Data {- -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in a Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. - Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals. @@ -363,6 +343,39 @@ For example Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c). +Note [Shadowing in Core] +~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if there is an invariant that a Core expression has no +"shadowing". For example, is this illegal? + \x. \x. blah -- x is shadowed +Answer; no! Core does /not/ have a no-shadowing invariant. + +Neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +It would in many ways be easier to have a no-shadowing invariant. And the +Simplifier does its best to clone variables that are shadowed. But it is +extremely difficult to GUARANTEE it: + +* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques + that are locally-unique (enough for the purpose) but not globally unique. + It is convenient not to have to plumb a unique supply to these functions. + +* It is very difficult for the Simplifier to gurantee a no-shadowing result. + See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration. + +* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE + +* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr + Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: ===================================== compiler/GHC/Core/Opt/CSE.hs ===================================== @@ -53,8 +53,8 @@ So we carry an extra var->var substitution which we apply *before* looking up in reverse mapping. -Note [Shadowing] -~~~~~~~~~~~~~~~~ +Note [Shadowing in CSE] +~~~~~~~~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider f = \x -> let y = x+x in @@ -900,7 +900,7 @@ extendCSSubst :: CSEnv -> Id -> CoreExpr -> CSEnv extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } -- | Add clones to the substitution to deal with shadowing. See --- Note [Shadowing] for more details. You should call this whenever +-- Note [Shadowing in CSE] for more details. You should call this whenever -- you go under a binder. addBinder :: CSEnv -> Var -> (CSEnv, Var) addBinder cse v = (cse { cs_subst = sub' }, v') ===================================== compiler/GHC/Core/Opt/FloatIn.hs ===================================== @@ -306,7 +306,7 @@ It is obviously bogus for FloatIn to transform to (y:ys) -> ...(let x = y+1 in x)... [] -> blah because the y is captured. This doesn't happen much, because shadowing is -rare, but it did happen in #22662. +rare (see Note [Shadowing in Core]), but it did happen in #22662. One solution would be to clone as we go. But a simpler one is this: ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -309,7 +309,7 @@ getCoreToDo dflags hpt_rule_base extra_vars [ CoreLiberateCase, simplify "post-liberate-case" ], -- Run the simplifier after LiberateCase to vastly -- reduce the possibility of shadowing - -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr + -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr runWhen spec_constr $ CoreDoPasses [ CoreDoSpecConstr, simplify "post-spec-constr"], ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -118,14 +118,6 @@ The general shape of the simplifier is this: The returned floats and env both have an in-scope set, and they are guaranteed to be the same. - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - Eta expansion ~~~~~~~~~~~~~~ For eta expansion, we want to catch things like @@ -261,7 +253,7 @@ simplRecBind env0 bind_cxt pairs0 = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 ; let new_bndrs = map sndOf3 triples ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> - go env triples + go env triples ; return (mkRecFloats rec_floats, env2) } where add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) @@ -302,10 +294,12 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | otherwise = case bind_cxt of BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ - simplJoinBind env is_rec cont old_bndr new_bndr rhs env + simplJoinBind is_rec cont + (old_bndr,env) (new_bndr,env) (rhs,env) BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + simplLazyBind top_lvl is_rec + (old_bndr,env) (new_bndr,env) (rhs,env) simplTrace :: String -> SDoc -> SimplM a -> SimplM a simplTrace herald doc thing_inside = do @@ -315,19 +309,16 @@ simplTrace herald doc thing_inside = do else thing_inside -------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId +simplLazyBind :: TopLevelFlag -> RecFlag + -> (InId, SimplEnv) -- InBinder, and static env for its unfolding (if any) + -> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder -- The OutId has IdInfo (notably RULES), -- except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment + -> (InExpr, SimplEnv) -- The RHS and its static environment -> SimplM (SimplFloats, SimplEnv) --- Precondition: the OutId is already in the InScopeSet of the incoming 'env' --- Precondition: not a JoinId +-- Precondition: Ids only, no TyVars; not a JoinId -- Precondition: rhs obeys the let-can-float invariant -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se +simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) = assert (isId bndr ) assertPpr (not (isJoinId bndr)) (ppr bndr) $ -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ @@ -378,24 +369,23 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds ; return (poly_floats, body3) } - ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env' tvs' body3 rhs_cont - ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' + ; let env1 = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1) ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- -simplJoinBind :: SimplEnv - -> RecFlag +simplJoinBind :: RecFlag -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env + -> (InId, SimplEnv) -- InBinder, with static env for its unfolding + -> (OutId, SimplEnv) -- OutBinder; SimplEnv has the binder in scope + -- The OutId has IdInfo, except arity, unfolding + -> (InExpr, SimplEnv) -- The right hand side and its env -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se +simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) = do { let rhs_env = rhs_se `setInScopeFromE` env ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } + ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } -------------------------- simplAuxBind :: SimplEnv @@ -406,7 +396,7 @@ simplAuxBind :: SimplEnv -- auxiliary bindings, notably in knownCon. -- -- The binder comes from a case expression (case binder or alternative) --- and so does not have rules, inline pragmas etc. +-- and so does not have rules, unfolding, inline pragmas etc. -- -- Precondition: rhs satisfies the let-can-float invariant @@ -435,8 +425,8 @@ simplAuxBind env bndr new_rhs -- Simplify the binder and complete the binding ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr - ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive) - bndr new_bndr rhs1 + ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (new_bndr, rhs1, env1) ; return (rhs_floats `addFloats` bind_float, env2) } @@ -842,7 +832,7 @@ makeTrivial env top_lvl dmd occ_fs expr ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 -- Technically we should extend the in-scope set in 'env' with -- the 'floats' from prepareRHS; but they are all fresh, so there is - -- no danger of introducing name shadowig in eta expansion + -- no danger of introducing name shadowing in eta expansion ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2 @@ -916,11 +906,11 @@ It does *not* attempt to do let-to-case. Why? Because it is used for Nor does it do the atomic-argument thing -} -completeBind :: SimplEnv - -> BindContext - -> InId -- Old binder - -> OutId -- New binder; can be a JoinId - -> OutExpr -- New RHS +completeBind :: BindContext + -> (InId, SimplEnv) -- Old binder, and the static envt in which to simplify + -- its stable unfolding (if any) + -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId. + -- And the SimplEnv with that OutId in scope. -> SimplM (SimplFloats, SimplEnv) -- completeBind may choose to do its work -- * by extending the substitution (e.g. let x = y in ...) @@ -928,7 +918,7 @@ completeBind :: SimplEnv -- -- Binder /can/ be a JoinId -- Precondition: rhs obeys the let-can-float invariant -completeBind env bind_cxt old_bndr new_bndr new_rhs +completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) | isCoVar old_bndr = case new_rhs of Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) @@ -944,9 +934,10 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr - eta_rhs (idType new_bndr) new_arity old_unf + -- Simplify the unfolding; see Note [Environment for simplLetUnfolding] + ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env) + bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding -- See Note [In-scope set as a substitution] @@ -1063,6 +1054,36 @@ postInlineUnconditionally will return True, but we may not have an unfolding because it's too big. Hence the belt-and-braces `orElse` in the defn of unf_rhs. The Nothing case probably never happens. +Note [Environment for simplLetUnfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be rather careful about the static environment in which +we simplify a stable unfolding. Consider (#24242): + + f x = let y_Xb = ... in + let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in + ... + +Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen; +see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier]. +This is perfectly fine. The `y_Xb` in the stable unfolding of the non- +recursive binding for `step1` refers, of course, to `let y_Xb = ....`. +When simplifying the binder `step1_Xb` we'll give it a new unique, and +extend the static environment with [Xb :-> step1_Xc], say. + +But when simplifying step1's stable unfolding, we must use static environment +/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps +[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc]. + +That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping +track of the right environment for the unfolding of that InId. See the type +of `simplLazyBind`, `simplJoinBind`, `completeBind`. + +This only matters when we have + - A non-recursive binding for f + - has a stable unfolding + - and that unfolding mentions a variable y + - that has the same unique as f. +So triggering a bug here is really hard! ************************************************************************ * * @@ -1524,7 +1545,7 @@ rebuild env expr cont completeBindX :: SimplEnv -> FromWhat - -> InId -> OutExpr -- Bind this Id to this (simplified) expression + -> InId -> OutExpr -- Non-recursively bind this Id to this (simplified) expression -- (the let-can-float invariant may not be satisfied) -> InExpr -- In this body -> SimplCont -- Consumed by this continuation @@ -1554,14 +1575,14 @@ completeBindX env from_what bndr rhs body cont -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', -- because this is simplNonRecX, so bndr is not in scope in the RHS. - ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats) - (BC_Let NotTopLevel NonRecursive) - bndr bndr2 rhs1 + ; let env3 = env2 `setInScopeFromF` rhs_floats + ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (bndr2, rhs1, env3) -- Must pass env1 to completeBind in case simplBinder had to clone, -- and extended the substitution with [bndr :-> new_bndr] -- Simplify the body - ; (body_floats, body') <- simplNonRecBody env2 from_what body cont + ; (body_floats, body') <- simplNonRecBody env4 from_what body cont ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats ; return ( all_floats, body' ) } @@ -1785,10 +1806,11 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs simplNonRecE :: HasDebugCallStack => SimplEnv -> FromWhat - -> InId -- The binder, always an Id - -- Never a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> InExpr -- Body of the let/lambda + -> InId -- The binder, always an Id + -- Never a join point + -- The static env for its unfolding (if any) is the first parameter + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -1817,8 +1839,8 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont | otherwise -- Evaluate RHS lazily = do { (env1, bndr1) <- simplNonRecBndr env bndr ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive - bndr bndr2 rhs rhs_se + ; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive + (bndr,env) (bndr2,env2) (rhs,rhs_se) ; (floats2, expr') <- simplNonRecBody env3 from_what body cont ; return (floats1 `addFloats` floats2, expr') } @@ -1944,7 +1966,7 @@ simplNonRecJoinPoint env bndr rhs body cont res_ty = contResultType cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env + ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) ; (floats2, body') <- simplExprF env3 body cont ; return (floats1 `addFloats` floats2, body') } @@ -2284,7 +2306,7 @@ rebuildCall env fun_info (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty , sc_dup = Simplified , sc_cont = cont }) - -- Note [Shadowing] + -- Note [Shadowing in the Simplifier] -- Lazy arguments | otherwise @@ -2413,10 +2435,10 @@ Here e1, e2 are simplified before the rule is applied, but don't really participate in the rule firing. So we mark them as Simplified to avoid re-simplifying them. -Note [Shadowing] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -Consider +Note [Shadowing in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This part of the simplifier may return an expression that has shadowing. +(See Note [Shadowing in Core] in GHC.Core.hs.) Consider f (...(\a -> e)...) (case y of (a,b) -> e') where f is strict in its second arg If we simplify the innermost one first we get (...(\a -> e)...) @@ -2437,6 +2459,8 @@ to get the effect that finding (error "foo") in a strict arg position will discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! +See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils. + Note [No eta-expansion in runRW#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see `runRW# (\s. blah)` we must not attempt to eta-expand that ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -190,10 +190,11 @@ data SimplCont | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] -- or, equivalently, = K[ (\x.b) e ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId , sc_from :: FromWhat + , sc_bndr :: InId , sc_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_env :: StaticEnv -- Static env for both sc_bndr (stable unfolding thereof) + -- and sc_body. Also see Note [StaticEnv invariant] , sc_cont :: SimplCont } | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] @@ -2290,7 +2291,7 @@ Note [Shadowing in prepareAlts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an /OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build -a new /InAlt/. If you pass an OutId, we'll end up appling the +a new /InAlt/. If you pass an OutId, we'll end up applying the substitution twice: disaster (#23012). However this does mean that filling in the default alt might be ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -254,7 +254,7 @@ So the grand plan is: * Find the free variables of the abstracted pattern * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. + the fn defn. But see Note [Shadowing in SpecConstr] below. NOTICE that we only abstract over variables that are not in scope, @@ -262,8 +262,8 @@ so we're in no danger of shadowing variables used in "higher up" in f_spec's RHS. -Note [Shadowing] -~~~~~~~~~~~~~~~~ +Note [Shadowing in SpecConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In this pass we gather up usage information that may mention variables that are bound between the usage site and the definition site; or (more seriously) may be bound to something different at the definition site. @@ -2503,7 +2503,7 @@ callToPat env bndr_occs call@(Call fn args con_env) -- Quantify over variables that are not in scope -- at the call site -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top + -- See Note [Shadowing in SpecConstr] at the top (qktvs, qids) = partition isTyVar qvars qvars' = scopedSort qktvs ++ map sanitise qids ===================================== compiler/GHC/Stg/CSE.hs ===================================== @@ -170,8 +170,8 @@ data CseEnv = CseEnv -- ^ This substitution is applied to the code as we traverse it. -- Entries have one of two reasons: -- - -- * The input might have shadowing (see Note [Shadowing]), so we have - -- to rename some binders as we traverse the tree. + -- * The input might have shadowing (see Note [Shadowing in Core]), + -- so we have to rename some binders as we traverse the tree. -- * If we remove `let x = Con z` because `let y = Con z` is in scope, -- we note this here as x ↦ y. , ce_bndrMap :: IdEnv OutId View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8baa1bdeea1753afc939a20119d3ce555301167 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8baa1bdeea1753afc939a20119d3ce555301167 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 Dec 8 20:55:33 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Fri, 08 Dec 2023 15:55:33 -0500 Subject: [Git][ghc/ghc][master] 3 commits: Comments only in FloatIn Message-ID: <657382c574bf_3478bc163101bc26622d@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 4 changed files: - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/SpecConstr.hs - + testsuite/tests/quantified-constraints/T22238.hs - testsuite/tests/quantified-constraints/all.T Changes: ===================================== compiler/GHC/Core/Opt/FloatIn.hs ===================================== @@ -234,6 +234,29 @@ Every jump must be exact, so the jump to j must have three arguments. Hence we're careful not to float into the target of a jump (though we can float into the arguments just fine). +Floating in can /enhance/ join points. Consider this (#3458) + f2 x = let g :: Int -> Int + g y = if y==0 then y+x else g (y-1) + in case g x of + 0 -> True + _ -> False + +Here `g` is not a join point. But if we float inwards it becomes one! We +float in; the occurrence analyser identifies `g` as a join point; the Simplifier +retains that property, so we get + f2 x = case (joinrec + g y = if y==0 then y+x else g (y-1) + in jump g x) of + 0 -> True + _ -> False + +Now that outer case gets pushed into the RHS of the joinrec, giving + f2 x = joinrec g y = if y==0 + then case y+x of { 0 -> True; _ -> False } + else jump g (y-1) + in jump g x +Nice! + Note [Floating in past a lambda group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We must be careful about floating inside a value lambda. ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -1948,6 +1948,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) `asJoinId_maybe` spec_join_arity -- Conditionally use result of new worker-wrapper transform + -- mkSeqs: see Note [SpecConstr and strict fields] spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body) rule_rhs = mkVarApps (Var spec_id) spec_call_args inline_act = idInlineActivation fn @@ -2345,6 +2346,8 @@ Then it's fine for `co2` to mention `a`. We'll get data CallPat = CP { cp_qvars :: [Var] -- Quantified variables , cp_args :: [CoreExpr] -- Arguments , cp_strict_args :: [Var] } -- Arguments we want to pass unlifted even if they are boxed + -- See Note [SpecConstr and strict fields] + -- See Note [SpecConstr call patterns] instance Outputable CallPat where ===================================== testsuite/tests/quantified-constraints/T22238.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE GADTs #-} + +module T22238 where + +import Data.Kind (Constraint) + +data Dict (c :: Constraint) where + MkDict :: c => Dict c + +forallListEqDict :: Dict (forall a. Eq a => Eq [a]) +forallListEqDict = MkDict ===================================== testsuite/tests/quantified-constraints/all.T ===================================== @@ -44,3 +44,4 @@ test('T19690', normal, compile_fail, ['']) test('T23143', normal, compile, ['']) test('T23333', normal, compile, ['']) test('T23323', normal, compile, ['']) +test('T22238', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8baa1bdeea1753afc939a20119d3ce555301167...9431e1953b29b2fe3e383b038258877efe9f6595 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8baa1bdeea1753afc939a20119d3ce555301167...9431e1953b29b2fe3e383b038258877efe9f6595 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 Dec 8 21:30:28 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 08 Dec 2023 16:30:28 -0500 Subject: [Git][ghc/ghc][wip/sym-type] rts/linker: Clearly define SymType Message-ID: <65738af482a03_3478bc178ccac827488e@gitlab.mail> Ben Gamari pushed to branch wip/sym-type at Glasgow Haskell Compiler / GHC Commits: ea9a0ae4 by Ben Gamari at 2023-12-08T16:30:02-05:00 rts/linker: Clearly define SymType Previously SymType was both an enumeration of three symbol types *and* an orthogonal flag (`DUP_DISCARD`, introduced in !9475). This was quite fragile as it meant that to extract the symbol type one had to careful mask out the flag. Naturally this wasn't done consistently. Fix this by renaming the field to `flags` and adding an accessor. Fixes #24117. - - - - - 5 changed files: - rts/Linker.c - rts/LinkerInternals.h - rts/linker/Elf.c - rts/linker/MachO.c - rts/linker/PEi386.c Changes: ===================================== rts/Linker.c ===================================== @@ -226,7 +226,7 @@ static void ghciRemoveSymbolTable(StrHashTable *table, const SymbolName* key, static const char * symbolTypeString (SymType type) { - switch (type & ~SYM_TYPE_DUP_DISCARD) { + switch (type) { case SYM_TYPE_CODE: return "code"; case SYM_TYPE_DATA: return "data"; case SYM_TYPE_INDIRECT_DATA: return "indirect-data"; @@ -262,6 +262,7 @@ int ghciInsertSymbolTable( SymbolAddr* data, SymStrength strength, SymType type, + SymDuplicable duplicable, ObjectCode *owner) { RtsSymbolInfo *pinfo = lookupStrHashTable(table, key); @@ -272,13 +273,14 @@ int ghciInsertSymbolTable( pinfo->owner = owner; pinfo->strength = strength; pinfo->type = type; + pinfo->duplicable = duplicable; insertStrHashTable(table, key, pinfo); return 1; } - else if (pinfo->type ^ type) + else if (pinfo->type != type) { /* We were asked to discard the symbol on duplicates, do so quietly. */ - if (!(type & SYM_TYPE_DUP_DISCARD)) + if (duplicable != SYM_DISCARD_ON_DUPLICATE) { debugBelch("Symbol type mismatch.\n"); debugBelch("Symbol %s was defined by %" PATH_FMT " to be a %s symbol.\n", @@ -466,7 +468,7 @@ initLinker_ (int retain_cafs) for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) { if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), symhash, sym->lbl, sym->addr, - sym->strength, sym->type, NULL)) { + sym->strength, sym->type, SYM_ERROR_ON_DUPLICATE, NULL)) { barf("ghciInsertSymbolTable failed"); } IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr)); @@ -476,7 +478,7 @@ initLinker_ (int retain_cafs) if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), symhash, MAYBE_LEADING_UNDERSCORE_STR("newCAF"), retain_cafs ? newRetainedCAF : newGCdCAF, - HS_BOOL_FALSE, SYM_TYPE_CODE, NULL)) { + HS_BOOL_FALSE, SYM_TYPE_CODE, SYM_ERROR_ON_DUPLICATE, NULL)) { barf("ghciInsertSymbolTable failed"); } @@ -864,7 +866,7 @@ HsBool removeLibrarySearchPath(HsPtr dll_path_index) HsInt insertSymbol(pathchar* obj_name, SymbolName* key, SymbolAddr* data) { return ghciInsertSymbolTable(obj_name, symhash, key, data, HS_BOOL_FALSE, - SYM_TYPE_CODE, NULL); + SYM_TYPE_CODE, SYM_ERROR_ON_DUPLICATE, NULL); } /* ----------------------------------------------------------------------------- @@ -1696,7 +1698,7 @@ int ocTryLoad (ObjectCode* oc) { && !ghciInsertSymbolTable(oc->fileName, symhash, symbol.name, symbol.addr, isSymbolWeak(oc, symbol.name), - symbol.type, oc)) { + symbol.type, SYM_ERROR_ON_DUPLICATE, oc)) { return 0; } } ===================================== rts/LinkerInternals.h ===================================== @@ -55,17 +55,24 @@ typedef struct _Section Section; /* What kind of thing a symbol identifies. We need to know this to determine how * to process overflowing relocations. See Note [Processing overflowed relocations]. - * This is bitfield however only the option SYM_TYPE_DUP_DISCARD can be combined - * with the other values. */ + * Be sure to update the width of RtsSymbolInfo.type if you add variants + * to this enumeration. + */ typedef enum _SymType { SYM_TYPE_CODE = 1 << 0, /* the symbol is a function and can be relocated via a jump island */ SYM_TYPE_DATA = 1 << 1, /* the symbol is data */ SYM_TYPE_INDIRECT_DATA = 1 << 2, /* see Note [_iob_func symbol] */ - SYM_TYPE_DUP_DISCARD = 1 << 3, /* the symbol is a symbol in a BFD import library - however if a duplicate is found with a mismatching - SymType then discard this one. */ } SymType; +/* How to handle duplicate symbols. */ +typedef enum { + // Throw an error if a duplicate symbol of different SymType is found + SYM_ERROR_ON_DUPLICATE = 0, + // Discard if a duplicate symbol of different SymType is found. This + // is necessary on PE platforms for symbols defined in BFD import + // libraries. + SYM_DISCARD_ON_DUPLICATE = 1 +} SymDuplicable; #if defined(OBJFORMAT_ELF) # include "linker/ElfTypes.h" @@ -438,7 +445,8 @@ typedef struct _RtsSymbolInfo { SymbolAddr* value; ObjectCode *owner; SymStrength strength; - SymType type; + SymType type: 16; + SymDuplicable duplicable: 1; } RtsSymbolInfo; #include "BeginPrivate.h" @@ -466,6 +474,7 @@ int ghciInsertSymbolTable( SymbolAddr* data, SymStrength weak, SymType type, + SymDuplicable duplicable, ObjectCode *owner); /* Lock-free version of lookupSymbol. When 'dependent' is not NULL, adds it as a ===================================== rts/linker/Elf.c ===================================== @@ -1083,7 +1083,7 @@ ocGetNames_ELF ( ObjectCode* oc ) setWeakSymbol(oc, nm); } if (!ghciInsertSymbolTable(oc->fileName, symhash, - nm, symbol->addr, isWeak, sym_type, oc) + nm, symbol->addr, isWeak, sym_type, SYM_ERROR_ON_DUPLICATE, oc) ) { goto fail; } ===================================== rts/linker/MachO.c ===================================== @@ -1390,14 +1390,15 @@ ocGetNames_MachO(ObjectCode* oc) { IF_DEBUG(linker_verbose, debugBelch("ocGetNames_MachO: inserting %s\n", nm)); SymbolAddr* addr = oc->info->macho_symbols[i].addr; - // TODO: Make figure out how to determine this from the object file - SymType sym_type = SYM_TYPE_CODE; + // TODO: Figure out how to determine this from the object file + const SymType sym_type = SYM_TYPE_CODE; ghciInsertSymbolTable( oc->fileName , symhash , nm , addr , HS_BOOL_FALSE , sym_type + , SYM_ERROR_ON_DUPLICATE , oc); oc->symbols[curSymbol].name = nm; @@ -1440,7 +1441,7 @@ ocGetNames_MachO(ObjectCode* oc) IF_DEBUG(linker_verbose, debugBelch("ocGetNames_MachO: inserting common symbol: %s\n", nm)); ghciInsertSymbolTable(oc->fileName, symhash, nm, - (void*)commonCounter, HS_BOOL_FALSE, sym_type, oc); + (void*)commonCounter, HS_BOOL_FALSE, sym_type, SYM_ERROR_ON_DUPLICATE, oc); oc->symbols[curSymbol].name = nm; oc->symbols[curSymbol].addr = oc->info->macho_symbols[i].addr; curSymbol++; ===================================== rts/linker/PEi386.c ===================================== @@ -299,7 +299,7 @@ These two issues mean that for GHC we need to take a different approach to handling import libraries. For normal C libraries we have proper differentiation between CODE and DATA. For GHC produced import libraries - we do not. As such the SYM_TYPE_DUP_DISCARD tells the linker that if a + we do not. As such the dup_discard flag tells the linker that if a duplicate symbol is found, and we were going to discard it anyway, just do so quitely. This works because the RTS symbols themselves are provided by the currently loaded RTS as built-in symbols. @@ -438,7 +438,7 @@ void initLinker_PEi386(void) if (!ghciInsertSymbolTable(WSTR("(GHCi/Ld special symbols)"), symhash, "__image_base__", GetModuleHandleW (NULL), HS_BOOL_TRUE, - SYM_TYPE_CODE, NULL)) { + SYM_TYPE_CODE, SYM_ERROR_ON_DUPLICATE, NULL)) { barf("ghciInsertSymbolTable failed"); } @@ -1814,9 +1814,8 @@ ocGetNames_PEi386 ( ObjectCode* oc ) sname = strdup (sname); addr = strdup (addr); type = has_code_section ? SYM_TYPE_CODE : SYM_TYPE_DATA; - type |= SYM_TYPE_DUP_DISCARD; if (!ghciInsertSymbolTable(oc->fileName, symhash, sname, - addr, false, type, oc)) { + addr, false, type, SYM_DISCARD_ON_DUPLICATE, oc)) { releaseOcInfo (oc); stgFree (oc->image); oc->image = NULL; @@ -1895,7 +1894,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) stgFree(tmp); sname = strdup (sname); if (!ghciInsertSymbolTable(oc->fileName, symhash, sname, - addr, false, type, oc)) + addr, false, type, SYM_ERROR_ON_DUPLICATE, oc)) return false; break; @@ -1918,7 +1917,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) } if (! ghciInsertSymbolTable(oc->fileName, symhash, sname, addr, - isWeak, type, oc)) + isWeak, type, SYM_ERROR_ON_DUPLICATE, oc)) return false; } else { /* We're skipping the symbol, but if we ever load this @@ -2324,7 +2323,9 @@ SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl, ObjectCode *dependent, SymType sym = lookupSymbolInDLLs(lbl, dependent); return sym; // might be NULL if not found } else { - if (type) *type = pinfo->type; + if (type) { + *type = pinfo->type; + } if (pinfo && pinfo->owner && isSymbolImport (pinfo->owner, lbl)) { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea9a0ae4628cf9d112cf4b32ea95930be7a371f6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ea9a0ae4628cf9d112cf4b32ea95930be7a371f6 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 Dec 8 21:39:36 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Fri, 08 Dec 2023 16:39:36 -0500 Subject: [Git][ghc/ghc][wip/int-index/rta-docs] docs: update information on RequiredTypeArguments Message-ID: <65738d184c903_3478bc17fea56c277223@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/rta-docs at Glasgow Haskell Compiler / GHC Commits: 05eba21b by Vladislav Zavialov at 2023-12-09T00:39:24+03: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. - - - - - 3 changed files: - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst Changes: ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,33 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,83 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Both ``forall a.`` and ``forall a ->`` are said to be dependent because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages. Neither ``forall a.`` nor ``forall a ->`` constitute a dependent function. + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This might not be obvious at first, as the +quantifiers themselves are clearly visible to our eye. + +The property actually describes whether GHC expects the type argument to be +supplied visibly at call sites:: + + b1 = id True -- there is a hidden, invisible type argument `Bool` + b2 = id_vdq Bool True -- there is a visible type argument `Bool` in the source code + +A similar difference exists at definition sites. The function equation for +``id`` does not mention any type variables:: + + id :: forall a. a -> a + id x = x -- the type variable `a` is not bound in the equation + +There is just one binder, ``x``, and it corresponds to the value argument, not +to the type argument. Compare that with the function equation for ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: +This time we have two binders on the LHS: - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature -At use sites, we also instantiate this type variable explicitly:: +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +111,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +133,199 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall - n = id_vdq Integer 42 +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2441,21 +2441,17 @@ of ``-W(no-)*``. :since: 9.8.1 - In accordance with `GHC Proposal #281 - `__, - a new extension ``RequiredTypeArguments`` will be introduced in a future GHC release. - - Under ``RequiredTypeArguments``, implicit quantification of type variables does not take place + Under :extension:`RequiredTypeArguments`, implicit quantification of type variables does not take place if there is a term variable of the same name in scope. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification - that would stop working under ``RequiredTypeArguments``. + that would stop working under :extension:`RequiredTypeArguments`. .. ghc-flag:: -Wmissing-role-annotations :shortdesc: warn when type declarations don't have role annotations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05eba21bc16362174e8320884b1d468db9d61fc7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05eba21bc16362174e8320884b1d468db9d61fc7 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 Dec 8 21:57:36 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Fri, 08 Dec 2023 16:57:36 -0500 Subject: [Git][ghc/ghc][wip/DataToTagSmallOp] Fiddle with documentation to address review comments Message-ID: <6573915098672_3478bc1861084c2778b3@gitlab.mail> Matthew Craven pushed to branch wip/DataToTagSmallOp at Glasgow Haskell Compiler / GHC Commits: 82795106 by Matthew Craven at 2023-12-08T16:56:37-05:00 Fiddle with documentation to address review comments - - - - - 4 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Instance/Class.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,8 +1131,8 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of dataToTagLarge# satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- -- Ignores applications not headed by dataToTagLarge#. @@ -1148,7 +1148,11 @@ checkDataToTagPrimOpTyCon (Var fun_id) args Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -1986,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3556,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3571,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -74,7 +74,8 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] -- dataToTagSmall# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW4 cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagSmall#") @@ -88,7 +89,8 @@ cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW4 cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -676,7 +676,7 @@ GHC generates instances like this: dataToTag# = dataToTagSmall# using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. -(These two primops differ only in code generation; see wrinkle DTW4 below.) +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# @@ -707,13 +707,19 @@ these conditions: But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + These two primops have special handling in several parts of the compiler: - They have a couple of built-in rewrite rules, implemented in GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing their result. +- The simplifier rewrites most case expressions scrutinizing their results. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. - Each evaluates its argument; this is implemented via special cases in @@ -791,7 +797,18 @@ Wrinkles: primops in DataToTag instances depending on the number of data constructors the relevant TyCon has. -(DTW5) We make no promises about the primops used to implement +(DTW5) We consider a call `dataToTagSmall# x` to result in undefined + behavior whenever the target supports pointer tagging but the actual + constructor index for `x` is too large to fit in the pointer's tag + bits. Otherwise, `dataToTagSmall#` behaves identically to + `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the @@ -804,6 +821,42 @@ Wrinkles: runtime and the index of that constructor is always exposed via pointer tagging and via the object's info table. +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169 and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + + Historical note: During its time as a primop, `dataToTag#` underwent several changes, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82795106afb05801c8220c6cc81e667d37303381 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82795106afb05801c8220c6cc81e667d37303381 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 Dec 9 10:04:58 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 05:04:58 -0500 Subject: [Git][ghc/ghc][wip/T20749] Make DataCon workers strict in strict fields (#20749) Message-ID: <65743bca34f41_3478bc29d80a1c32543a@gitlab.mail> Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC Commits: 2fb45f12 by Sebastian Graf at 2023-12-09T11:04:33+01:00 Make DataCon workers strict in strict fields (#20749) This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand Analysis so that they exploit and maintain strictness of DataCon workers. See `Note [Strict fields in Core]` for details. Very little needed to change, and it puts field seq insertion done by Tag Inference into a new perspective: That of *implementing* strict field semantics. Before Tag Inference, DataCon workers are strict. Afterwards they are effectively lazy and field seqs happen around use sites. History has shown that there is no other way to guarantee taggedness and thus the STG Strict Field Invariant. Knock-on changes: * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments instead of recursing into `exprIsHNF`. That regressed the termination analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made it call `exprOkForSpeculation`, too. * There's a small regression in Demand Analysis, visible in the changed test output of T16859: Previously, a field seq on a variable would give that variable a "used exactly once" demand, now it's "used at least once", because `dmdTransformDataConSig` accounts for future uses of the field that actually all go through the case binder (and hence won't re-enter the potential thunk). The difference should hardly be observable. * The Simplifier's fast path for data constructors only applies to lazy data constructors now. I observed regressions involving Data.Binary.Put's `Pair` data type. * Unfortunately, T21392 does no longer reproduce after this patch, so I marked it as "not broken" in order to track whether we regress again in the future. Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas in #21497 and #22475). Co-Authored-By: Jaro Reinders <jaro.reinders at gmail.com> - - - - - 22 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Utils/Misc.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplStg/should_compile/inferTags002.stderr - testsuite/tests/stranal/sigs/T16859.stderr Changes: ===================================== compiler/GHC/Builtin/Types.hs ===================================== @@ -636,6 +636,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri -- See Note [Constructor tag allocation] and #14657 data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) + (map (const HsLazy) arg_tys) + (map (const NotMarkedStrict) arg_tys) [] -- No labelled fields tyvars ex_tyvars conc_tyvars ===================================== compiler/GHC/Core.hs ===================================== @@ -42,7 +42,7 @@ module GHC.Core ( foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, collectFunSimple, exprToType, @@ -1005,6 +1005,59 @@ tail position: A cast changes the type, but the type must be the same. But operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Evaluating a data constructor worker evaluates its strict fields. + +In other words, if `MkT` is strict in its first field and `xs` reduces to +`error "boom"`, then `MkT xs b` will throw that error. +Conversely, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field seq insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + + * `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + + * `exprIsConApp_maybe` inserts field seqs in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. + all see the inserted field seqs when they match on strict workers. Often this + is just to emphasise strict semantics, but for case-of-known constructor + and case-to-let, field insertion is *vital*, otherwise these transformations + would lose field seqs. + + * The demand signature of a data constructor is strict in strict field + position, whereas is it's normally lazy. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + + * In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited in STG by Note [Tag Inference]: +It performs field seq insertion to statically guarantee *taggedness* of strict +fields, establishing the Note [STG Strict Field Invariant]. (Happily, most +of those seqs are immediately detected as redundant by tag inference and are +omitted.) From then on, DataCon worker semantics are actually lazy, hence it is +important that STG passes maintain the Strict Field Invariant. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + ************************************************************************ * * In/Out type synonyms @@ -2091,6 +2144,17 @@ collectArgs expr go (App f a) as = go f (a:as) go e as = (e, as) +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectValArgs :: Expr b -> (Expr b, [Arg b]) +collectValArgs expr + = go expr [] + where + go (App f a) as + | isValArg a = go f (a:as) + | otherwise = go f as + go e as = (e, as) + -- | Takes a nested application expression and returns the function -- being applied. Looking through casts and ticks to find it. collectFunSimple :: Expr b -> Expr b ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -49,7 +49,8 @@ module GHC.Core.DataCon ( dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, + dataConRepStrictness, dataConRepStrictness_maybe, + dataConImplBangs, dataConBoxer, splitDataProductType_maybe, @@ -60,7 +61,7 @@ module GHC.Core.DataCon ( isVanillaDataCon, isNewDataCon, isTypeDataCon, classDataCon, dataConCannotMatch, dataConUserTyVarsNeedWrapper, checkDataConTyVars, - isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, + isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, -- ** Promotion related functions @@ -97,6 +98,7 @@ import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) import GHC.Data.Graph.UnVar -- UnVarSet and operations +import GHC.Data.Maybe (orElse) import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars ) @@ -524,6 +526,18 @@ data DataCon -- Matches 1-1 with dcOrigArgTys -- Hence length = dataConSourceArity dataCon + dcImplBangs :: [HsImplBang], + -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + dcStricts :: [StrictnessMark], + -- One mark for every field of the DataCon worker; + -- if it's empty, then all fields are lazy, + -- otherwise it has the same length as dataConRepArgTys. + -- See also Note [Strict fields in Core] in GHC.Core + -- for the effect on the strictness signature + dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the dcOrigArgTys; @@ -826,13 +840,6 @@ data DataConRep -- after unboxing and flattening, -- and *including* all evidence args - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - } type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon @@ -901,43 +908,8 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) -{- Note [Data-con worker strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we do *not* say the worker Id is strict even if the data -constructor is declared strict - e.g. data T = MkT ![Int] Bool -Even though most often the evals are done by the *wrapper* $WMkT, there are -situations in which tag inference will re-insert evals around the worker. -So for all intents and purposes the *worker* MkT is strict, too! - -Unfortunately, if we exposed accurate strictness of DataCon workers, we'd -see the following transformation: - - f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs - ==> { drop-seq, binder swap on xs' } - f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs - ==> { case-to-let } - f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs! - -I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs` -and then doing case-to-let. The issue is that `exprIsHNF` currently says that -every DataCon worker app is a value. The implicit assumption is that surrounding -evals will have evaluated strict fields like `xs` before! But now that we had -just dropped the eval on `xs`, that assumption is no longer valid. - -Long story short: By keeping the demand signature lazy, the Simplifier will not -drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others -remains sound. - -Similarly, during demand analysis in dmdTransformDataConSig, we bump up the -field demand with `C_01`, *not* `C_11`, because the latter exposes too much -strictness that will drop the eval on `xs` above. - -This issue is discussed at length in -"Failed idea: no wrappers for strict data constructors" in #21497 and #22475. - -Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -963,8 +935,8 @@ Terminology: the flag settings in the importing module. Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be +* The dcImplBangs field records the [HsImplBang] + If T was defined in this module, Without -O the dcImplBangs might be [HsStrict _, HsStrict _, HsLazy] With -O it might be [HsStrict _, HsUnpack _, HsLazy] @@ -973,6 +945,17 @@ Terminology: With -XStrictData it might be [HsStrict _, HsUnpack _, HsStrict _] +* Core passes will often need to know whether the DataCon worker or wrapper in + an application is strict in some (lifted) field or not. This is tracked in the + demand signature attached to a DataCon's worker resp. wrapper Id. + + So if you've got a DataCon dc, you can get the demand signature by + `idDmdSig (dataConWorkId dc)` and make out strict args by testing with + `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives + you the demand signature of the wrapper, if it exists. + + These demand signatures are set in GHC.Types.Id.Make. + Note [Detecting useless UNPACK pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to issue a warning when there's an UNPACK pragma in the source code, @@ -1008,7 +991,6 @@ we consult HsImplBang: The boolean flag is used only for this warning. See #11270 for motivation. - ************************************************************************ * * \subsection{Instances} @@ -1110,6 +1092,11 @@ isBanged (HsUnpack {}) = True isBanged (HsStrict {}) = True isBanged HsLazy = False +isUnpacked :: HsImplBang -> Bool +isUnpacked (HsUnpack {}) = True +isUnpacked (HsStrict {}) = False +isUnpacked HsLazy = False + isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False @@ -1135,13 +1122,15 @@ cbvFromStrictMark MarkedStrict = MarkedCbv -- | Build a new data constructor mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler + -> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. -> ConcreteTyVars -- ^ TyVars which must be instantiated with -- concrete types @@ -1163,7 +1152,9 @@ mkDataCon :: Name -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 + arg_stricts -- Must match orig_arg_tys 1-1 + impl_bangs -- Must match orig_arg_tys 1-1 + str_marks -- Must be empty or match dataConRepArgTys 1-1 fields univ_tvs ex_tvs conc_tvs user_tvbs eq_spec theta @@ -1180,6 +1171,8 @@ mkDataCon name declared_infix prom_info = con where is_vanilla = null ex_tvs && null eq_spec && null theta + str_marks' | not $ any isMarkedStrict str_marks = [] + | otherwise = str_marks con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, @@ -1192,7 +1185,8 @@ mkDataCon name declared_infix prom_info dcStupidTheta = stupid_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, + dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs, + dcStricts = str_marks', dcFields = fields, dcTag = tag, dcRepType = rep_ty, dcWorkId = work_id, dcRep = rep, @@ -1436,19 +1430,27 @@ isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness dc + = dataConRepStrictness_maybe dc + `orElse` map (const NotMarkedStrict) (dataConRepArgTys dc) + +dataConRepStrictness_maybe :: DataCon -> Maybe [StrictnessMark] +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application or `Nothing` if all of them are lazy. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness_maybe dc + | null (dcStricts dc) = Nothing + | otherwise = Just (dcStricts dc) dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs +dataConImplBangs dc = dcImplBangs dc dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -1463,7 +1463,7 @@ myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] - cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -296,9 +296,16 @@ data TermFlag -- Better than using a Bool -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag +-- ^ A /very/ simple termination analysis. exprTerminates e - | exprIsHNF e = Terminates -- A /very/ simple termination analysis. - | otherwise = MightDiverge + | exprIsHNF e = Terminates + | exprOkForSpeculation e = Terminates + | otherwise = MightDiverge + -- Annyingly, we have to check both for HNF and ok-for-spec. + -- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing! + -- * `lvl` is an HNF if its unfolding is evaluated + -- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never + -- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables]. cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) -- Main function that takes care of /nested/ CPR. See Note [Nested CPR] ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -824,6 +824,10 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +You might think that we should check for side-effects rather than just for +precise exceptions. Right you are! See Note [Side-effects and strictness] +for why we unfortunately do not. + Note [Demand analysis for recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T11545 features a single-product, recursive data type ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -8,14 +8,13 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - SimplMode(..), updMode, - smPedanticBottoms, smPlatform, + SimplMode(..), updMode, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, - seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seOptCoercionOpts, sePhase, sePlatform, sePreInline, seRuleOpts, seRules, seUnfoldingOpts, mkSimplEnv, extendIdSubst, extendTvSubst, extendCvSubst, @@ -219,9 +218,6 @@ seNames env = sm_names (seMode env) seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePedanticBottoms :: SimplEnv -> Bool -sePedanticBottoms env = smPedanticBottoms (seMode env) - sePhase :: SimplEnv -> CompilerPhase sePhase env = sm_phase (seMode env) @@ -276,9 +272,6 @@ instance Outputable SimplMode where where pp_flag f s = ppUnless f (text "no") <+> s -smPedanticBottoms :: SimplMode -> Bool -smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) - smPlatform :: SimplMode -> Platform smPlatform opts = roPlatform (sm_rule_opts opts) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Core.Reduction import GHC.Core.Coercion.Opt ( optCoercion ) import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness + ( DataCon, dataConWorkId, dataConRepStrictness, dataConRepStrictness_maybe , dataConRepArgTys, isUnboxedTupleDataCon , StrictnessMark (..) ) import GHC.Core.Opt.Stats ( Tick(..) ) @@ -2102,14 +2102,14 @@ zap the SubstEnv. This is VITAL. Consider We'll clone the inner \x, adding x->x' in the id_subst Then when we inline y, we must *not* replace x by x' in the inlined copy!! -Note [Fast path for data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Fast path for lazy data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For applications of a data constructor worker, the full glory of rebuildCall is a waste of effort; * They never inline, obviously * They have no rewrite rules -* They are not strict (see Note [Data-con worker strictness] - in GHC.Core.DataCon) +* Though they might be strict (see Note [Strict fields in Core] in GHC.Core), + we will exploit that strictness through their demand signature So it's fine to zoom straight to `rebuild` which just rebuilds the call in a very straightforward way. @@ -2133,7 +2133,8 @@ simplVar env var simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont - | isDataConWorkId var -- See Note [Fast path for data constructors] + | Just dc <- isDataConWorkId_maybe var -- See Note [Fast path for lazy data constructors] + , Nothing <- dataConRepStrictness_maybe dc = rebuild env (Var var) cont | otherwise = case substId env var of @@ -3318,7 +3319,7 @@ a case pattern. This is *important*. Consider We really must record that b is already evaluated so that we don't go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Core.DataCon +See Note [Strict fields in Core] in GHC.Core. NB: simplLamBndrs preserves this eval info ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1272,11 +1272,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } - = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) - float = FloatCase arg' bndr DEFAULT [] - subst' = subst_extend_in_scope subst bndr - in go subst' (float:floats) fun (CC (Var bndr : args) co) + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) co) | otherwise = go subst floats fun (CC (subst_expr subst arg : args) co) @@ -1315,8 +1312,10 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args co + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + -- mkFieldSeqFloats: See Note [Strict fields in Core] + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' co -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do @@ -1402,6 +1401,38 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + -- See Note [Strict fields in Core] for what a field seq is and why we + -- insert them + mkFieldSeqFloats in_scope dc args + | Nothing <- dataConRepStrictness_maybe dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = no_seq + | exprIsHNF arg = no_seq + | otherwise = (in_scope', float:floats, Var bndr:args) + where + no_seq = (in_scope, floats, arg:args) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> Coercion ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Core.Type ( splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe, splitForAllTyCoVar_maybe, splitForAllTyCoVar, splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, + splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders, getRuntimeArgTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, @@ -292,6 +292,7 @@ import GHC.Data.FastString import Control.Monad ( guard ) import GHC.Data.Maybe ( orElse, isJust ) +import GHC.List (build) -- $type_classification -- #type_classification# @@ -2004,6 +2005,18 @@ splitPiTys ty = split ty ty [] split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) +collectPiTyBinders :: Type -> [PiTyBinder] +collectPiTyBinders ty = build $ \c n -> + let + split (ForAllTy b res) = Named b `c` split res + split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = Anon (Scaled w arg) af `c` split res + split ty | Just ty' <- coreView ty = split ty' + split _ = n + in + split ty +{-# INLINE collectPiTyBinders #-} + -- | Extracts a list of run-time arguments from a function type, -- looking through newtypes to the right of arrows. -- ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -1269,18 +1269,23 @@ in this (which it previously was): in \w. v True -} --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree e = exprIsCheapX isWorkFreeApp e - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap e = exprIsCheapX isCheapApp e +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool {-# INLINE exprIsCheapX #-} --- allow specialization of exprIsCheap and exprIsWorkFree +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable -- instead of having an unknown call to ok_app -exprIsCheapX ok_app e +-- expandable: Only True for exprIsExpandable, where Case and Let are never +-- expandable. +exprIsCheapX ok_app expandable e = ok e where ok e = go 0 e @@ -1299,90 +1304,26 @@ exprIsCheapX ok_app e | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f - go n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + go n (Let (NonRec _ r) e) = not expandable && go n e && ok r + go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs -- Case: see Note [Case expressions are work-free] -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e -{- Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to duplicate it, if doing -so might make a RULE or case-of-constructor fire. Consider - let x = (a,b) - y = build g - in ....(case x of (p,q) -> rhs)....(foldr k z y).... - -We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), -but we do want - - * the case-expression to simplify - (via exprIsConApp_maybe, exprIsLiteral_maybe) - - * the foldr/build RULE to fire - (by expanding the unfolding during rule matching) - -So we classify the unfolding of a let-binding as "expandable" (via the -uf_expandable field) if we want to do this kind of on-the-fly -expansion. Specifically: - -* True of constructor applications (K a b) - -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. - (NB: exprIsCheap might not be true of this) - -* False of case-expressions. If we have - let x = case ... in ...(case x of ...)... - we won't simplify. We have to inline x. See #14688. - -* False of let-expressions (same reason); and in any case we - float lets out of an RHS if doing so will reveal an expandable - application (see SimplEnv.doFloatFromRhs). - -* Take care: exprIsExpandable should /not/ be true of primops. I - found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... - - q's inlining should not be expandable, else exprIsConApp_maybe will - say that (q @ Float) expands to (Ptr a (a +# b)), and that will - duplicate the (a +# b) primop, which we should not do lightly. - (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) --} +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e -------------------------------------- +-------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] -exprIsExpandable e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = isExpandableApp v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Case {}) = False - go _ (Let {}) = False - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp +exprIsExpandable e = exprIsCheapX isExpandableApp True e isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args @@ -1402,7 +1343,7 @@ isCheapApp fn n_val_args | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId op _ -> primOpIsCheap op @@ -1417,6 +1358,7 @@ isExpandableApp fn n_val_args | isWorkFreeApp fn n_val_args = True | otherwise = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False @@ -1448,6 +1390,50 @@ isExpandableApp fn n_val_args I'm not sure why we have a special case for bottoming functions in isCheapApp. Maybe we don't need it. +Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) + Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming @@ -1628,7 +1614,7 @@ expr_ok fun_ok primop_ok other_expr _ -> False ----------------------------- -app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool app_ok fun_ok primop_ok fun args | not (fun_ok fun) = False -- This code path is only taken for Note [Speculative evaluation] @@ -1643,13 +1629,11 @@ app_ok fun_ok primop_ok fun args -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not - DataConWorkId {} -> args_ok - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account - -- Well, we thought so. But it's definitely wrong! - -- See #20749 and Note [How untagged pointers can - -- end up in strict fields] in GHC.Stg.InferTags + DataConWorkId dc + | Just str_marks <- dataConRepStrictness_maybe dc + -> fields_ok str_marks + | otherwise + -> args_ok ClassOpId _ is_terminating_result | is_terminating_result -- See Note [exprOkForSpeculation and type classes] @@ -1699,7 +1683,7 @@ app_ok fun_ok primop_ok fun args -- Even if a function call itself is OK, any unlifted -- args are still evaluated eagerly and must be checked - args_ok = and (zipWith arg_ok arg_tys args) + args_ok = all2Prefix arg_ok arg_tys args arg_ok :: PiTyVarBinder -> CoreExpr -> Bool arg_ok (Named _) _ = True -- A type argument arg_ok (Anon ty _) arg -- A term argument @@ -1708,6 +1692,17 @@ app_ok fun_ok primop_ok fun args | otherwise = expr_ok fun_ok primop_ok arg + -- Used for DataCon worker arguments + fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args + field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool + field_ok (Named _) _ _ = True + field_ok (Anon ty _) str arg + | NotMarkedStrict <- str -- iff it's a lazy field + , definitelyLiftedType (scaledThing ty) -- and its type is lifted + = True -- then the worker app does not eval + | otherwise + = expr_ok fun_ok primop_ok arg + ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alternatives are definitely exhaustive @@ -1933,12 +1928,14 @@ exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding -- or PAPs. -- exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like +exprIsHNFlike is_con is_con_unf e + = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $ + is_hnf_like e where is_hnf_like (Var v) -- NB: There are no value args at this point - = id_app_is_value v 0 -- Catches nullary constructors, - -- so that [] and () are values, for example - -- and (e.g.) primops that don't have unfoldings + = id_app_is_value v [] -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value -- or to a guaranteed-evaluated variable (isEvaldUnfolding) @@ -1962,7 +1959,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like -- See Note [exprIsHNF Tick] is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e a) - | isValArg a = app_is_value e 1 + | isValArg a = app_is_value e [a] | otherwise = is_hnf_like e is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like (Case e b _ as) @@ -1970,26 +1967,53 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like = is_hnf_like rhs is_hnf_like _ = False - -- 'n' is the number of value args to which the expression is applied - -- And n>0: there is at least one value argument - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = - app_is_value f (nva + 1) && - not (needsCaseBinding (exprType a) a) - -- For example f (x /# y) where f has arity two, and the first - -- argument is unboxed. This is not a value! - -- But f 34# is a value. - -- NB: Check app_is_value first, the arity check is cheaper - | otherwise = app_is_value f nva - app_is_value _ _ = False - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args + -- Collect arguments through Casts and Ticks and call id_app_is_value + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var f) as = id_app_is_value f as + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as | isValArg a = app_is_value f (a:as) + | otherwise = app_is_value f as + app_is_value _ _ = False + + id_app_is_value id val_args + -- First handle saturated applications of DataCons with strict fields + | Just dc <- isDataConWorkId_maybe id -- DataCon + , Just str_marks <- dataConRepStrictness_maybe dc -- with strict fields + , assert (val_args `leLength` str_marks) True + , val_args `equalLength` str_marks -- in a saturated app + = all3Prefix check_field val_arg_tys str_marks val_args + + -- Now all applications except saturated DataCon apps with strict fields + | idArity id > length val_args + -- PAP: Check unlifted val_args + || is_con id && isNothing (isDataConWorkId_maybe id >>= dataConRepStrictness_maybe) + -- Either a lazy DataCon or a CONLIKE. + -- Hence we only need to check unlifted val_args here. + -- NB: We assume that CONLIKEs are lazy, which is their entire + -- point. + = all2Prefix check_arg val_arg_tys val_args + + | otherwise + = False + where + fun_ty = idType id + val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty) + -- val_arg_tys = map exprType val_args, but much less costly. + -- The obvious definition regresses T16577 by 30% so we don't do it. + + check_arg a_ty a = mightBeUnliftedType a_ty ==> is_hnf_like a + -- Check unliftedness; for example f (x /# 12#) where f has arity two, + -- and the first argument is unboxed. This is not a value! + -- But f 34# is a value, so check args for HNFs. + -- NB: We check arity (and CONLIKEness) first because it's cheaper + -- and we reject quickly on saturated apps. + check_field a_ty str a + = isMarkedStrict str || mightBeUnliftedType a_ty ==> is_hnf_like a + -- isMarkedStrict: Respect Note [Strict fields in Core] + a ==> b = not a || b + infixr 1 ==> +{-# INLINE exprIsHNFlike #-} {- Note [exprIsHNF Tick] @@ -2551,7 +2575,7 @@ This means the seqs on x and y both become no-ops and compared to the first vers The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated -already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this. +already at the call site because of the Strict Field Invariant! See Note [STG Strict Field Invariant] for more in this. This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. We only apply this when we think there is a benefit in doing so however. There are a number of cases in which ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -65,8 +65,8 @@ With nofib being ~0.3% faster as well. See Note [Tag inference passes] for how we proceed to generate and use this information. -Note [Strict Field Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [STG Strict Field Invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As part of tag inference we introduce the Strict Field Invariant. Which consists of us saying that: @@ -82,7 +82,7 @@ and will be tagged with `001` or `010` respectively. It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. -This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids]. +This works analogous to how CBV functions work. See also Note [CBV Function Ids]. Why do we care? Because if we have code like: @@ -104,7 +104,7 @@ where we: * If not we convert `StrictJust x` into `case x of x' -> StrictJust x'` This is usually very beneficial but can cause regressions in rare edge cases where -we fail to proof that x is properly tagged, or where it simply isn't. +we fail to prove that x is properly tagged, or where it simply isn't. See Note [How untagged pointers can end up in strict fields] for how the second case can arise. @@ -125,15 +125,33 @@ Note that there are similar constraints around Note [CBV Function Ids]. Note [How untagged pointers can end up in strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the resolution of #20749 where Core passes assume that DataCon workers +evaluate their strict fields, it is pretty simple to see how the Simplifier +might exploit that knowledge to drop evals. Example: + + data MkT a = MkT !a + f :: [Int] -> T [Int] + f xs = xs `seq` MkT xs + +in Core we will have + + f = \xs -> MkT @[Int] xs + +No eval left there. + Consider data Set a = Tip | Bin !a (Set a) (Set a) We make a wrapper for Bin that evaluates its arguments $WBin x a b = case x of xv -> Bin xv a b Here `xv` will always be evaluated and properly tagged, just as the -Strict Field Invariant requires. +Note [STG Strict Field Invariant] requires. + +But alas, the Simplifier can destroy the invariant: see #15696. +Indeed, as Note [Strict fields in Core] explains, Core passes +assume that Data constructor workers evaluate their strict fields, +so the Simplifier will drop seqs freely. -But alas the Simplifier can destroy the invariant: see #15696. We start with thk = f () g x = ...(case thk of xv -> Bin xv Tip Tip)... @@ -154,7 +172,7 @@ Now you can see that the argument of Bin, namely thk, points to the thunk, not to the value as it did before. In short, although it may be rare, the output of optimisation passes -cannot guarantee to obey the Strict Field Invariant. For this reason +cannot guarantee to obey the Note [STG Strict Field Invariant]. For this reason we run tag inference. See Note [Tag inference passes]. Note [Tag inference passes] @@ -164,7 +182,7 @@ Tag inference proceeds in two passes: The result is then attached to /binders/. This is implemented by `inferTagsAnal` in GHC.Stg.InferTags * The second pass walks over the AST checking if the Strict Field Invariant is upheld. - See Note [Strict Field Invariant]. + See Note [STG Strict Field Invariant]. If required this pass modifies the program to uphold this invariant. Tag information is also moved from /binders/ to /occurrences/ during this pass. This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`. ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -65,7 +65,7 @@ The work of this pass is simple: * For any strict field we check if the argument is known to be properly tagged. * If it's not known to be properly tagged, we wrap the whole thing in a case, which will force the argument before allocation. -This is described in detail in Note [Strict Field Invariant]. +This is described in detail in Note [STG Strict Field Invariant]. The only slight complication is that we have to make sure not to invalidate free variable analysis in the process. @@ -218,7 +218,7 @@ When compiling bytecode we call myCoreToStg to get STG code first. myCoreToStg in turn calls out to stg2stg which runs the STG to STG passes followed by free variables analysis and the tag inference pass including its rewriting phase at the end. -Running tag inference is important as it upholds Note [Strict Field Invariant]. +Running tag inference is important as it upholds Note [STG Strict Field Invariant]. While code executed by GHCi doesn't take advantage of the SFI it can call into compiled code which does. So it must still make sure that the SFI is upheld. See also #21083 and #22042. ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -799,7 +799,7 @@ mostly relating to under what circumstances it evaluates its argument. Today, that story is simple: A dataToTag primop always evaluates its argument, unless tag inference determines the argument was already evaluated and correctly tagged. Getting here was a long journey, with -many similarities to the story behind Note [Strict Field Invariant] in +many similarities to the story behind Note [STG Strict Field Invariant] in GHC.Stg.InferTags. See also #15696. -} ===================================== compiler/GHC/Tc/TyCl/Build.hs ===================================== @@ -183,14 +183,15 @@ buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls + src_bangs impl_bangs str_marks field_lbls univ_tvs ex_tvs noConcreteTyVars user_tvbs eq_spec ctxt arg_tys res_ty NoPromInfo rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) + (dc_rep, impl_bangs, str_marks) = + initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -1385,33 +1385,8 @@ arguments. That is the job of dmdTransformDataConSig. More precisely, * it returns the demands on the arguments; in the above example that is [SL, A] -Nasty wrinkle. Consider this code (#22475 has more realistic examples but -assume this is what the demand analyser sees) - - data T = MkT !Int Bool - get :: T -> Bool - get (MkT _ b) = b - - foo = let v::Int = I# 7 - t::T = MkT v True - in get t - -Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand, -else we'll drop the binding and replace it with an error thunk. -Then the code generator (more specifically GHC.Stg.InferTags.Rewrite) -will add an extra eval of MkT's argument to give - foo = let v::Int = error "absent" - t::T = case v of v' -> MkT v' True - in get t - -Boo! Because of this extra eval (added in STG-land), the truth is that `MkT` -may (or may not) evaluate its arguments (as established in #21497). Hence the -use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The -`C_01` says "may or may not evaluate" which is absolutely faithful to what -InferTags.Rewrite does. - -In particular it is very important /not/ to make that a `C_11` eval, -see Note [Data-con worker strictness]. +When the data constructor worker has strict fields, they act as additional +seqs; hence we add an additional `C_11` eval. -} {- ********************************************************************* @@ -1611,6 +1586,29 @@ a bad fit because expression may not throw a precise exception (increasing precision of the analysis), but that's just a favourable guess. +Note [Side-effects and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to historic reasons and the continued effort not to cause performance +regressions downstream, Strictness Analysis is currently prone to discarding +observable side-effects (other than precise exceptions, see +Note [Precise exceptions and strictness analysis]) in some cases. For example, + f :: MVar () -> Int -> IO Int + f mv x = putMVar mv () >> (x `seq` return x) +The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis +currently concludes that `f` is strict in `x` and uses call-by-value. +That means `f mv (error "boom")` will error out with the imprecise exception +rather performing the side-effect. + +This is a conscious violation of the semantics described in the paper +"a semantics for imprecise exceptions"; so it would be great if we could +identify the offending primops and extend the idea in +Note [Which scrutinees may throw precise exceptions] to general side-effects. + +Unfortunately, the existing has-side-effects classification for primops is +too conservative, listing `writeMutVar#` and even `readMutVar#` as +side-effecting. That is due to #3207. A possible way forward is described in +#17900, but no effort has been so far towards a resolution. + Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore. @@ -2327,7 +2325,7 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) | otherwise = multDmd n dmd - str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness] + str_field_dmd = C_11 :* seqSubDmd -- See Note [Strict fields in Core] -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -260,7 +260,7 @@ The invariants around the arguments of call by value function like Ids are then: * Any `WorkerLikeId` * Some `JoinId` bindings. -This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant]. +This works analogous to the Strict Field Invariant. See also Note [STG Strict Field Invariant]. To make this work what we do is: * During W/W and SpecConstr any worker/specialized binding we introduce ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -58,7 +58,7 @@ import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) +import GHC.Core.Utils ( exprType, mkCast, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -594,8 +594,12 @@ mkDataConWorkId wkr_name data_con = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + str_marks = dataConRepStrictness data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo @@ -603,12 +607,19 @@ mkDataConWorkId wkr_name data_con `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedDmdSig wkr_dmds topDiv + wkr_dmds = map mk_dmd str_marks + mk_dmd MarkedStrict = evalDmd + mk_dmd NotMarkedStrict = topDmd + -- See Note [LFInfo of DataCon workers and wrappers] wkr_lf_info | wkr_arity == 0 = LFCon data_con @@ -616,9 +627,6 @@ mkDataConWorkId wkr_name data_con -- LFInfo stores post-unarisation arity ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - ex_tcvs = dataConExTyCoVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setInlinePragInfo` dataConWrapperInlinePragma @@ -786,10 +794,10 @@ mkDataConRep :: DataConBangOpts -> FamInstEnvs -> Name -> DataCon - -> UniqSM DataConRep + -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) mkDataConRep dc_bang_opts fam_envs wrap_name data_con | not wrapper_reqd - = return NoDataConRep + = return (NoDataConRep, arg_ibangs, rep_strs) | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys @@ -853,11 +861,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } + , dcr_arg_tys = rep_tys } + , arg_ibangs, rep_strs) } where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) @@ -907,8 +912,8 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. - && (any isBanged (ev_ibangs ++ arg_ibangs))) - -- Some forcing/unboxing (includes eq_spec) + && (any isUnpacked (ev_ibangs ++ arg_ibangs))) + -- Some unboxing (includes eq_spec) || isFamInstTyCon tycon -- Cast result || (dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and @@ -1185,7 +1190,7 @@ dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep arg_ty (HsStrict _) - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG dataConArgRep arg_ty (HsUnpack Nothing) = dataConArgUnpack arg_ty @@ -1215,9 +1220,6 @@ wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) ===================================== compiler/GHC/Utils/Misc.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Utils.Misc ( dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, - List.foldl1', foldl2, count, countWhile, all2, + List.foldl1', foldl2, count, countWhile, all2, all2Prefix, all3Prefix, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -663,6 +663,30 @@ all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False +all2Prefix :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`. +-- So if one list is shorter than the other, `p` is assumed to be `True` for the +-- suffix. +all2Prefix p = foldr k z + where + k x go ys' = case ys' of + (y:ys'') -> p x y && go ys'' + _ -> True + z _ = True +{-# INLINE all2Prefix #-} + +all3Prefix :: (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool +-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`. +-- So if one list is shorter than the others, `p` is assumed to be `True` for +-- the suffix. +all3Prefix p = foldr k z + where + k x go ys' zs' = case (ys',zs') of + (y:ys'',z:zs'') -> p x y z && go ys'' zs'' + _ -> False + z _ _ = True +{-# INLINE all3Prefix #-} + -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -418,7 +418,10 @@ test('T21391', normal, compile, ['-O -dcore-lint']) test('T22112', [ grep_errmsg('never matches') ], compile, ['-O -dsuppress-uniques -dno-typeable-binds -fexpose-all-unfoldings -ddump-simpl']) test('T21391a', normal, compile, ['-O -dcore-lint']) # We don't want to see a thunk allocation for the insertBy expression after CorePrep. -test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken(21392) ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) +# Unfortunately, this test is no longer broken after we made workers strict in strict fields, +# so it is no longer a reproducer for T21392. Still, it doesn't hurt if we test that we don't +# regress again. +test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]') ], compile, ['-O -ddump-prep -dno-typeable-binds -dsuppress-uniques']) test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O']) test('T21801', normal, compile, ['-O -dcore-lint']) test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec']) ===================================== testsuite/tests/simplStg/should_compile/inferTags002.stderr ===================================== @@ -1,88 +1,30 @@ -==================== Output Cmm ==================== -[M.$WMkT_entry() { // [R3, R2] - { info_tbls: [(cym, - label: block_cym_info - rep: StackRep [False] - srt: Nothing), - (cyp, - label: M.$WMkT_info - rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } - srt: Nothing), - (cys, - label: block_cys_info - rep: StackRep [False] - srt: Nothing)] - stack_info: arg_space: 8 - } - {offset - cyp: // global - if ((Sp + -16) < SpLim) (likely: False) goto cyv; else goto cyw; - cyv: // global - R1 = M.$WMkT_closure; - call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - cyw: // global - I64[Sp - 16] = cym; - R1 = R2; - P64[Sp - 8] = R3; - Sp = Sp - 16; - if (R1 & 7 != 0) goto cym; else goto cyn; - cyn: // global - call (I64[R1])(R1) returns to cym, args: 8, res: 8, upd: 8; - cym: // global - I64[Sp] = cys; - _sy8::P64 = R1; - R1 = P64[Sp + 8]; - P64[Sp + 8] = _sy8::P64; - call stg_ap_0_fast(R1) returns to cys, args: 8, res: 8, upd: 8; - cys: // global - Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto cyA; else goto cyz; - cyA: // global - HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cys, args: 8, res: 8, upd: 8; - cyz: // global - I64[Hp - 16] = M.MkT_con_info; - P64[Hp - 8] = P64[Sp + 8]; - P64[Hp] = R1; - R1 = Hp - 15; - Sp = Sp + 16; - call (P64[Sp])(R1) args: 8, res: 0, upd: 8; - } - }, - section ""data" . M.$WMkT_closure" { - M.$WMkT_closure: - const M.$WMkT_info; - }] - - - ==================== Output Cmm ==================== [M.f_entry() { // [R2] - { info_tbls: [(cyK, - label: block_cyK_info + { info_tbls: [(cAs, + label: block_info rep: StackRep [] srt: Nothing), - (cyN, + (cAv, label: M.f_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cyN: // global - if ((Sp + -8) < SpLim) (likely: False) goto cyO; else goto cyP; - cyO: // global + _lbl_: // global + if ((Sp + -8) < SpLim) (likely: False) goto cAw; else goto cAx; + _lbl_: // global R1 = M.f_closure; call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; - cyP: // global - I64[Sp - 8] = cyK; + _lbl_: // global + I64[Sp - 8] = cAs; R1 = R2; Sp = Sp - 8; - if (R1 & 7 != 0) goto cyK; else goto cyL; - cyL: // global - call (I64[R1])(R1) returns to cyK, args: 8, res: 8, upd: 8; - cyK: // global + if (R1 & 7 != 0) goto cAs; else goto cAt; + _lbl_: // global + call (I64[R1])(R1) returns to cAs, args: 8, res: 8, upd: 8; + _lbl_: // global R1 = P64[R1 + 15]; Sp = Sp + 8; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; @@ -97,47 +39,47 @@ ==================== Output Cmm ==================== [M.MkT_entry() { // [R3, R2] - { info_tbls: [(cz1, - label: block_cz1_info + { info_tbls: [(cAJ, + label: block_info rep: StackRep [False] srt: Nothing), - (cz4, + (cAM, label: M.MkT_info rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 15} } srt: Nothing), - (cz7, - label: block_cz7_info + (cAP, + label: block_info rep: StackRep [False] srt: Nothing)] stack_info: arg_space: 8 } {offset - cz4: // global - if ((Sp + -16) < SpLim) (likely: False) goto cza; else goto czb; - cza: // global + _lbl_: // global + if ((Sp + -16) < SpLim) (likely: False) goto cAS; else goto cAT; + _lbl_: // global R1 = M.MkT_closure; call (stg_gc_fun)(R3, R2, R1) args: 8, res: 0, upd: 8; - czb: // global - I64[Sp - 16] = cz1; + _lbl_: // global + I64[Sp - 16] = cAJ; R1 = R2; P64[Sp - 8] = R3; Sp = Sp - 16; - if (R1 & 7 != 0) goto cz1; else goto cz2; - cz2: // global - call (I64[R1])(R1) returns to cz1, args: 8, res: 8, upd: 8; - cz1: // global - I64[Sp] = cz7; - _tyf::P64 = R1; + if (R1 & 7 != 0) goto cAJ; else goto cAK; + _lbl_: // global + call (I64[R1])(R1) returns to cAJ, args: 8, res: 8, upd: 8; + _lbl_: // global + I64[Sp] = cAP; + __locVar_::P64 = R1; R1 = P64[Sp + 8]; - P64[Sp + 8] = _tyf::P64; - call stg_ap_0_fast(R1) returns to cz7, args: 8, res: 8, upd: 8; - cz7: // global + P64[Sp + 8] = __locVar_::P64; + call stg_ap_0_fast(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global Hp = Hp + 24; - if (Hp > HpLim) (likely: False) goto czf; else goto cze; - czf: // global + if (Hp > HpLim) (likely: False) goto cAX; else goto cAW; + _lbl_: // global HpAlloc = 24; - call stg_gc_unpt_r1(R1) returns to cz7, args: 8, res: 8, upd: 8; - cze: // global + call stg_gc_unpt_r1(R1) returns to cAP, args: 8, res: 8, upd: 8; + _lbl_: // global I64[Hp - 16] = M.MkT_con_info; P64[Hp - 8] = P64[Sp + 8]; P64[Hp] = R1; @@ -155,14 +97,14 @@ ==================== Output Cmm ==================== [M.MkT_con_entry() { // [] - { info_tbls: [(czl, + { info_tbls: [(cB3, label: M.MkT_con_info rep: HeapRep 2 ptrs { Con {tag: 0 descr:"main:M.MkT"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - czl: // global + _lbl_: // global R1 = R1 + 1; call (P64[Sp])(R1) args: 8, res: 0, upd: 8; } ===================================== testsuite/tests/stranal/sigs/T16859.stderr ===================================== @@ -4,7 +4,7 @@ T16859.bar: <1!A> T16859.baz: <1L><1!P(L)><1C(1,L)> T16859.buz: <1!P(L,L)> T16859.foo: <1L> -T16859.mkInternalName: <1!P(L)><1L><1L> +T16859.mkInternalName: <1!P(L)> T16859.n_loc: <1!P(A,A,A,1L)> T16859.n_occ: <1!P(A,1!P(L,L),A,A)> T16859.n_sort: <1!P(1L,A,A,A)> View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb45f126fdcdfd1e715d998d194254ac1148137 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fb45f126fdcdfd1e715d998d194254ac1148137 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 Dec 9 12:59:35 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sat, 09 Dec 2023 07:59:35 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove last EpAnn from HsExpr extension points Message-ID: <657464b74a020_3478bc2db812583298aa@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 5f0e07d8 by Alan Zimmerman at 2023-12-09T12:59:08+00:00 EPA: Remove last EpAnn from HsExpr extension points - - - - - 6 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/ThToHs.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -184,10 +184,10 @@ data HsBracketTc = HsBracketTc -- pasted back in by the desugarer } -type instance XTypedBracket GhcPs = EpAnn [AddEpAnn] +type instance XTypedBracket GhcPs = [AddEpAnn] type instance XTypedBracket GhcRn = NoExtField type instance XTypedBracket GhcTc = HsBracketTc -type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn] +type instance XUntypedBracket GhcPs = [AddEpAnn] type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices] -- Output of the renamer is the *original* renamed expression, -- plus _renamed_ splices to be type checked @@ -271,7 +271,7 @@ type instance XPar GhcPs = (EpToken "(", EpToken ")") type instance XPar GhcRn = NoExtField type instance XPar GhcTc = NoExtField -type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] +type instance XExplicitTuple GhcPs = [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField type instance XExplicitTuple GhcTc = NoExtField @@ -299,7 +299,7 @@ type instance XDo GhcPs = AnnList type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = EpAnn AnnList +type instance XExplicitList GhcPs = AnnList type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -310,11 +310,11 @@ type instance XExplicitList GhcTc = Type -- See Note [Handling overloaded and rebindable constructs] -- in GHC.Rename.Expr -type instance XRecordCon GhcPs = EpAnn [AddEpAnn] +type instance XRecordCon GhcPs = [AddEpAnn] type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function -type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] +type instance XRecordUpd GhcPs = [AddEpAnn] type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = DataConCantHappen -- We desugar record updates in the typechecker. @@ -346,29 +346,29 @@ type instance XLHsRecUpdLabels GhcTc = DataConCantHappen type instance XLHsOLRecUpdLabels p = NoExtField -type instance XGetField GhcPs = EpAnnCO +type instance XGetField GhcPs = NoExtField type instance XGetField GhcRn = NoExtField type instance XGetField GhcTc = DataConCantHappen -- HsGetField is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XProjection GhcPs = EpAnn AnnProjection +type instance XProjection GhcPs = AnnProjection type instance XProjection GhcRn = NoExtField type instance XProjection GhcTc = DataConCantHappen -- HsProjection is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn] +type instance XExprWithTySig GhcPs = [AddEpAnn] type instance XExprWithTySig GhcRn = NoExtField type instance XExprWithTySig GhcTc = NoExtField -type instance XArithSeq GhcPs = EpAnn [AddEpAnn] +type instance XArithSeq GhcPs = [AddEpAnn] type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XProc (GhcPass _) = EpAnn [AddEpAnn] +type instance XProc (GhcPass _) = [AddEpAnn] -type instance XStatic GhcPs = EpAnn [AddEpAnn] +type instance XStatic GhcPs = [AddEpAnn] type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = (NameSet, Type) -- Free variables and type of expression, this is stored for convenience as wiring in @@ -1756,17 +1756,17 @@ data HsUntypedSpliceResult thing -- 'thing' can be HsExpr or HsType } | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point -type instance XTypedSplice GhcPs = (EpAnnCO, EpAnn [AddEpAnn]) +type instance XTypedSplice GhcPs = [AddEpAnn] type instance XTypedSplice GhcRn = SplicePointName type instance XTypedSplice GhcTc = DelayedSplice -type instance XUntypedSplice GhcPs = EpAnnCO +type instance XUntypedSplice GhcPs = NoExtField type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) type instance XUntypedSplice GhcTc = DataConCantHappen -- HsUntypedSplice -type instance XUntypedSpliceExpr GhcPs = EpAnn [AddEpAnn] -type instance XUntypedSpliceExpr GhcRn = EpAnn [AddEpAnn] +type instance XUntypedSpliceExpr GhcPs = [AddEpAnn] +type instance XUntypedSpliceExpr GhcRn = [AddEpAnn] type instance XUntypedSpliceExpr GhcTc = DataConCantHappen type instance XQuasiQuote p = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -2845,7 +2845,7 @@ fexp :: { ECP } | 'static' aexp {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsStatic (EpAnn (glEE $1 $>) [mj AnnStatic $1] cs) $2) } + amsA' (sLL $1 $> $ HsStatic [mj AnnStatic $1] $2) } | aexp { $1 } @@ -2929,7 +2929,7 @@ aexp :: { ECP } {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4 at cmd -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsProc (EpAnn (glEE $1 $>) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 $> $ HsCmdTop noExtField cmd)) } + amsA' (sLL $1 $> $ HsProc [mj AnnProc $1,mu AnnRarrow $3] p (sLLa $1 $> $ HsCmdTop noExtField cmd)) } | aexp1 { $1 } @@ -2945,9 +2945,9 @@ aexp1 :: { ECP } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> - fmap ecpFromExp $ acsA (\cs -> + fmap ecpFromExp $ amsA' ( let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in - sLL $1 $> $ mkRdrGetField $1 fl (EpAnn (glEE $1 $>) NoEpAnns cs)) } + sLL $1 $> $ mkRdrGetField $1 fl) } @@ -2983,7 +2983,7 @@ aexp2 :: { ECP } -- This case is only possible when 'OverloadedRecordDotBit' is enabled. | '(' projection ')' { ECP $ - acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glEE $1 $>) (AnnProjection (glAA $1) (glAA $3)) cs)) + amsA' (sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (AnnProjection (glAA $1) (glAA $3)) ) >>= ecpFromExp' } @@ -3003,26 +3003,26 @@ aexp2 :: { ECP } | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 } | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) } - | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } - | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } - | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) } - | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) } + | SIMPLEQUOTE qvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) } + | SIMPLEQUOTE qcon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) } + | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1 ] (VarBr noExtField False $2)) } + | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1 ] (VarBr noExtField False $2)) } -- See Note [%shift: aexp2 -> TH_TY_QUOTE] | TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) } | '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] - else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) } + amsA' (sLL $1 $> $ HsUntypedBracket (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] + else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) (ExpBr noExtField $2)) } | '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glEE $1 $>) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) } + amsA' (sLL $1 $> $ HsTypedBracket (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) $2) } | '[t|' ktype '|]' {% fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) } + amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (TypBr noExtField $2)) } | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p -> fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) } + amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (PatBr noExtField p)) } | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ - acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glEE $1 $>) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) } + amsA' (sLL $1 $> $ HsUntypedBracket (mo $1:mu AnnCloseQ $3:fst $2) (DecBrL noExtField (snd $2))) } | quasiquote { ECP $ pvA $ mkHsSplicePV $1 } -- arrow notation extension @@ -3039,19 +3039,19 @@ projection | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) } splice_exp :: { LHsExpr GhcPs } - : splice_untyped { fmap (HsUntypedSplice noAnn) (reLoc $1) } + : splice_untyped { fmap (HsUntypedSplice noExtField) (reLoc $1) } | splice_typed { fmap (uncurry HsTypedSplice) (reLoc $1) } splice_untyped :: { Located (HsUntypedSplice GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - acs (\cs -> sLL $1 $> $ HsUntypedSpliceExpr (EpAnn (glEE $1 $>) [mj AnnDollar $1] cs) $2) } + return (sLL $1 $> $ HsUntypedSpliceExpr [mj AnnDollar $1] $2) } -splice_typed :: { Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs) } +splice_typed :: { Located ([AddEpAnn], LHsExpr GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - acs (\cs -> sLL $1 $> $ ((noAnn, EpAnn (glEE $1 $>) [mj AnnDollarDollar $1] cs), $2)) } + return (sLL $1 $> $ ([mj AnnDollarDollar $1], $2)) } cmdargs :: { [LHsCmdTop GhcPs] } : cmdargs acmd { $2 : $1 } @@ -3163,23 +3163,23 @@ list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (Locate | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1)) + amsA' (L loc $ ArithSeq [ao,mj AnnDotdot $2,ac] Nothing (From $1)) >>= ecpFromExp' } | texp ',' exp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3)) + amsA' (L loc $ ArithSeq [ao,mj AnnComma $2,mj AnnDotdot $4,ac] Nothing (FromThen $1 $3)) >>= ecpFromExp' } | texp '..' exp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3)) + amsA' (L loc $ ArithSeq [ao,mj AnnDotdot $2,ac] Nothing (FromTo $1 $3)) >>= ecpFromExp' } | texp ',' exp '..' exp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> unECP $5 >>= \ $5 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5)) + amsA' (L loc $ ArithSeq [ao,mj AnnComma $2,mj AnnDotdot $4,ac] Nothing (FromThenTo $1 $3 $5)) >>= ecpFromExp' } | texp '|' flattenedpquals { \loc (ao,ac) -> @@ -4360,7 +4360,7 @@ ams1 (L l a) b = do cs <- getCommentsFor (locA l) return (L (EpAnn (spanAsAnchor l) noAnn cs) b) -amsA' :: MonadP m => Located a -> m (LocatedA a) +amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a) amsA' (L l a) = do cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) a) ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1835,18 +1835,18 @@ instance DisambECP (HsExpr GhcPs) where cs <- getCommentsFor (locA l) return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) - mkHsTySigPV l a sig anns = do + mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do cs <- getCommentsFor (locA l) - return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig)) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig)) mkHsExplicitListPV l xs anns = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs) mkHsSplicePV sp@(L l _) = do cs <- getCommentsFor l - return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp + return $ fmap (HsUntypedSplice NoExtField) sp mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do cs <- getCommentsFor l - r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs) + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns checkRecordSyntax (L (noAnnSrcSpan l) r) mkHsNegAppPV l a anns = do cs <- getCommentsFor l @@ -2565,7 +2565,7 @@ mkRecConstrOrUpdate -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) - -> EpAnn [AddEpAnn] + -> [AddEpAnn] -> PV (HsExpr GhcPs) mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns | isRdrDataCon c @@ -2580,7 +2580,7 @@ mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns PsErrDotsInRecordUpdate | otherwise = mkRdrRecordUpd overloaded_update exp fs anns -mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> [AddEpAnn] -> PV (HsExpr GhcPs) mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- We do not need to know if OverloadedRecordDot is in effect. We do -- however need to know if OverloadedRecordUpdate (passed in @@ -2641,7 +2641,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f mkRdrRecordCon - :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs + :: LocatedN RdrName -> HsRecordBinds GhcPs -> [AddEpAnn] -> HsExpr GhcPs mkRdrRecordCon con flds anns = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } @@ -3132,9 +3132,9 @@ mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) -- Tuple -mkSumOrTupleExpr l boxity (Tuple es) anns = do +mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do cs <- getCommentsFor (locA l) - return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity) where toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs toTupArg (Left ann) = missingTupArg ann @@ -3220,15 +3220,15 @@ starSym False = fsLit "*" -- Bits and pieces for RecordDotSyntax. mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) - -> EpAnnCO -> HsExpr GhcPs -mkRdrGetField arg field anns = + -> HsExpr GhcPs +mkRdrGetField arg field = HsGetField { - gf_ext = anns + gf_ext = NoExtField , gf_expr = arg , gf_field = field } -mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs +mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs mkRdrProjection flds anns = HsProjection { proj_ext = anns ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -1655,8 +1655,8 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField mk_typed_bracket = HsTypedBracket noAnn - mk_tsplice = HsTypedSplice (noAnn, noAnn) - mk_usplice = HsUntypedSplice noAnn . HsUntypedSpliceExpr noAnn + mk_tsplice = HsTypedSplice [] + mk_usplice = HsUntypedSplice noExtField . HsUntypedSpliceExpr noAnn data_cons = getPossibleDataCons tycon tycon_args pats_etc mk_bracket mk_splice lift_name data_con ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1156,12 +1156,12 @@ cvtl e = wrapLA (cvt e) cvt (LabelE s) = return $ HsOverLabel noExtField NoSourceText (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp - ; return $ HsGetField noComments e' + ; return $ HsGetField noExtField e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) } cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e - ; return $ HsTypedSplice (noAnn, noAnn) e' } + ; return $ HsTypedSplice [] e' } cvt (TypedBracketE e) = do { e' <- cvtl e ; return $ HsTypedBracket noAnn e' } cvt (TypeE t) = do { t' <- cvtType t ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1305,11 +1305,6 @@ markLensKw' a l kw = do loc <- markKwA kw (view l a) return (set l loc a) --- TODO: delete this in favour of markLensKw -markAnnKwL :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) -markAnnKwL = markLensKw - markAnnKwAllL :: (Monad m, Monoid w) => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a) markAnnKwAllL (EpAnn anc a cs) l kw = do @@ -2943,81 +2938,8 @@ instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where -- --------------------------------------------------------------------- instance ExactPrint (HsExpr GhcPs) where - getAnnotationEntry (HsVar{}) = NoEntryVal - getAnnotationEntry (HsUnboundVar{}) = NoEntryVal - getAnnotationEntry (HsRecSel{}) = NoEntryVal - getAnnotationEntry (HsOverLabel{}) = NoEntryVal - getAnnotationEntry (HsIPVar{}) = NoEntryVal - getAnnotationEntry (HsOverLit{}) = NoEntryVal - getAnnotationEntry (HsLit{}) = NoEntryVal - getAnnotationEntry (HsLam{}) = NoEntryVal - getAnnotationEntry (HsApp{}) = NoEntryVal - getAnnotationEntry (HsAppType _ _ _) = NoEntryVal - getAnnotationEntry (OpApp _ _ _ _) = NoEntryVal - getAnnotationEntry (NegApp _ _ _) = NoEntryVal - getAnnotationEntry (HsPar{}) = NoEntryVal - getAnnotationEntry (SectionL _ _ _) = NoEntryVal - getAnnotationEntry (SectionR _ _ _) = NoEntryVal - getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an - getAnnotationEntry (ExplicitSum _ _ _ _) = NoEntryVal - getAnnotationEntry (HsCase _ _ _) = NoEntryVal - getAnnotationEntry (HsIf _ _ _ _) = NoEntryVal - getAnnotationEntry (HsMultiIf _ _) = NoEntryVal - getAnnotationEntry (HsLet _ _ _) = NoEntryVal - getAnnotationEntry (HsDo _ _ _) = NoEntryVal - getAnnotationEntry (ExplicitList an _) = fromAnn an - getAnnotationEntry (RecordCon an _ _) = fromAnn an - getAnnotationEntry (RecordUpd an _ _) = fromAnn an - getAnnotationEntry (HsGetField an _ _) = fromAnn an - getAnnotationEntry (HsProjection an _) = fromAnn an - getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an - getAnnotationEntry (ArithSeq an _ _) = fromAnn an - getAnnotationEntry (HsTypedBracket an _) = fromAnn an - getAnnotationEntry (HsUntypedBracket an _) = fromAnn an - getAnnotationEntry (HsTypedSplice (_, an) _) = fromAnn an - getAnnotationEntry (HsUntypedSplice an _) = fromAnn an - getAnnotationEntry (HsProc an _ _) = fromAnn an - getAnnotationEntry (HsStatic an _) = fromAnn an - getAnnotationEntry (HsPragE{}) = NoEntryVal - getAnnotationEntry (HsEmbTy{}) = NoEntryVal - - setAnnotationAnchor a@(HsVar{}) _ _ _s = a - setAnnotationAnchor a@(HsUnboundVar{}) _ _ _s = a - setAnnotationAnchor a@(HsRecSel{}) _ _ _s = a - setAnnotationAnchor a@(HsOverLabel{}) _ _ _s = a - setAnnotationAnchor a@(HsIPVar{}) _ _ _s = a - setAnnotationAnchor a@(HsOverLit {}) _ _ _s = a - setAnnotationAnchor a@(HsLit {}) _ _ _s = a - setAnnotationAnchor a@(HsLam{}) _ _ _s = a - setAnnotationAnchor a@(HsApp{}) _ _ _s = a - setAnnotationAnchor a@(HsAppType {}) _ _ _s = a - setAnnotationAnchor a@(OpApp{}) _ _ _s = a - setAnnotationAnchor a@(NegApp{}) _ _ _s = a - setAnnotationAnchor a@(HsPar {}) _ _ _s = a - setAnnotationAnchor a@(SectionL{}) _ _ _s = a - setAnnotationAnchor a@(SectionR{}) _ _ _s = a - setAnnotationAnchor (ExplicitTuple an a b) anc ts cs = (ExplicitTuple (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(ExplicitSum{}) _ _ _s = a - setAnnotationAnchor a@(HsCase{}) _ _ _s = a - setAnnotationAnchor a@(HsIf{}) _ _ _s = a - setAnnotationAnchor a@(HsMultiIf{}) _ _ _s = a - setAnnotationAnchor a@(HsLet{}) _ _ _s = a - setAnnotationAnchor a@(HsDo{}) _ _ _s = a - setAnnotationAnchor (ExplicitList an a) anc ts cs = (ExplicitList (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (RecordCon an a b) anc ts cs = (RecordCon (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (RecordUpd an a b) anc ts cs = (RecordUpd (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsGetField an a b) anc ts cs = (HsGetField (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsProjection an a) anc ts cs = (HsProjection (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (ExprWithTySig an a b) anc ts cs = (ExprWithTySig (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (ArithSeq an a b) anc ts cs = (ArithSeq (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsTypedBracket an a) anc ts cs = (HsTypedBracket (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsUntypedBracket an a) anc ts cs = (HsUntypedBracket (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsTypedSplice (x,an) e) anc ts cs = (HsTypedSplice (x,(setAnchorEpa an anc ts cs)) e) - setAnnotationAnchor (HsUntypedSplice an e) anc ts cs = (HsUntypedSplice (setAnchorEpa an anc ts cs) e) - setAnnotationAnchor (HsProc an a b) anc ts cs = (HsProc (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsStatic an a) anc ts cs = (HsStatic (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(HsPragE{}) _ _ _s = a - setAnnotationAnchor a@(HsEmbTy{}) _ _ _s = a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a exact (HsVar x n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be @@ -3111,13 +3033,13 @@ instance ExactPrint (HsExpr GhcPs) where return (SectionR an op' expr') exact (ExplicitTuple an args b) = do - an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP - else markEpAnnL an lidl AnnOpenPH + an0 <- if b == Boxed then markEpAnnL' an lidl AnnOpenP + else markEpAnnL' an lidl AnnOpenPH args' <- mapM markAnnotated args - an1 <- if b == Boxed then markEpAnnL an0 lidl AnnCloseP - else markEpAnnL an0 lidl AnnClosePH + an1 <- if b == Boxed then markEpAnnL' an0 lidl AnnCloseP + else markEpAnnL' an0 lidl AnnClosePH debugM $ "ExplicitTuple done" return (ExplicitTuple an1 args' b) @@ -3172,132 +3094,133 @@ instance ExactPrint (HsExpr GhcPs) where exact (ExplicitList an es) = do debugM $ "ExplicitList start" - an0 <- markLensMAA an lal_open + an0 <- markLensMAA' an lal_open es' <- markAnnotated es - an1 <- markLensMAA an0 lal_close + an1 <- markLensMAA' an0 lal_close debugM $ "ExplicitList end" return (ExplicitList an1 es') exact (RecordCon an con_id binds) = do con_id' <- markAnnotated con_id - an0 <- markEpAnnL an lidl AnnOpenC + an0 <- markEpAnnL' an lidl AnnOpenC binds' <- markAnnotated binds - an1 <- markEpAnnL an0 lidl AnnCloseC + an1 <- markEpAnnL' an0 lidl AnnCloseC return (RecordCon an1 con_id' binds') exact (RecordUpd an expr fields) = do expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnOpenC + an0 <- markEpAnnL' an lidl AnnOpenC fields' <- markAnnotated fields - an1 <- markEpAnnL an0 lidl AnnCloseC + an1 <- markEpAnnL' an0 lidl AnnCloseC return (RecordUpd an1 expr' fields') exact (HsGetField an expr field) = do expr' <- markAnnotated expr field' <- markAnnotated field return (HsGetField an expr' field') exact (HsProjection an flds) = do - an0 <- markAnnKwL an lapOpen AnnOpenP + an0 <- markLensKw' an lapOpen AnnOpenP flds' <- mapM markAnnotated flds - an1 <- markAnnKwL an0 lapClose AnnCloseP + an1 <- markLensKw' an0 lapClose AnnCloseP return (HsProjection an1 flds') exact (ExprWithTySig an expr sig) = do expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon sig' <- markAnnotated sig return (ExprWithTySig an0 expr' sig') exact (ArithSeq an s seqInfo) = do - an0 <- markEpAnnL an lidl AnnOpenS -- '[' + an0 <- markEpAnnL' an lidl AnnOpenS -- '[' (an1, seqInfo') <- case seqInfo of From e -> do e' <- markAnnotated e - an' <- markEpAnnL an0 lidl AnnDotdot + an' <- markEpAnnL' an0 lidl AnnDotdot return (an', From e') FromTo e1 e2 -> do e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnDotdot + an' <- markEpAnnL' an0 lidl AnnDotdot e2' <- markAnnotated e2 return (an', FromTo e1' e2') FromThen e1 e2 -> do e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma + an' <- markEpAnnL' an0 lidl AnnComma e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot + an'' <- markEpAnnL' an' lidl AnnDotdot return (an'', FromThen e1' e2') FromThenTo e1 e2 e3 -> do e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma + an' <- markEpAnnL' an0 lidl AnnComma e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot + an'' <- markEpAnnL' an' lidl AnnDotdot e3' <- markAnnotated e3 return (an'', FromThenTo e1' e2' e3') - an2 <- markEpAnnL an1 lidl AnnCloseS -- ']' + an2 <- markEpAnnL' an1 lidl AnnCloseS -- ']' return (ArithSeq an2 s seqInfo') exact (HsTypedBracket an e) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") - an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") + an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[||") + an1 <- markEpAnnLMS'' an0 lidl AnnOpenE (Just "[e||") e' <- markAnnotated e - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") + an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "||]") return (HsTypedBracket an2 e') exact (HsUntypedBracket an (ExpBr a e)) = do - an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" - an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional + an0 <- markEpAnnL' an lidl AnnOpenEQ -- "[|" + an1 <- markEpAnnL' an0 lidl AnnOpenE -- "[e|" -- optional e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]" + an2 <- markEpAnnL' an1 lidl AnnCloseQ -- "|]" return (HsUntypedBracket an2 (ExpBr a e')) exact (HsUntypedBracket an (PatBr a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|") + an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[p|") e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + an1 <- markEpAnnL' an0 lidl AnnCloseQ -- "|]" return (HsUntypedBracket an1 (PatBr a e')) exact (HsUntypedBracket an (DecBrL a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") - an1 <- markEpAnnL an0 lidl AnnOpenC + an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[d|") + an1 <- markEpAnnL' an0 lidl AnnOpenC e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseC - an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" + an2 <- markEpAnnL' an1 lidl AnnCloseC + an3 <- markEpAnnL' an2 lidl AnnCloseQ -- "|]" return (HsUntypedBracket an3 (DecBrL a e')) exact (HsUntypedBracket an (TypBr a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|") + an0 <- markEpAnnLMS'' an lidl AnnOpen (Just "[t|") e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" + an1 <- markEpAnnL' an0 lidl AnnCloseQ -- "|]" return (HsUntypedBracket an1 (TypBr a e')) exact (HsUntypedBracket an (VarBr a b e)) = do (an0, e') <- if b then do - an' <- markEpAnnL an lidl AnnSimpleQuote + an' <- markEpAnnL' an lidl AnnSimpleQuote e' <- markAnnotated e return (an', e') else do - an' <- markEpAnnL an lidl AnnThTyQuote + an' <- markEpAnnL' an lidl AnnThTyQuote e' <- markAnnotated e return (an', e') return (HsUntypedBracket an0 (VarBr a b e')) - exact (HsTypedSplice (x,an) s) = do - an0 <- markEpAnnL an lidl AnnDollarDollar + exact (HsTypedSplice an s) = do + an0 <- markEpAnnL' an lidl AnnDollarDollar s' <- exact s - return (HsTypedSplice (x,an0) s') + return (HsTypedSplice an0 s') + exact (HsUntypedSplice an s) = do s' <- exact s return (HsUntypedSplice an s') exact (HsProc an p c) = do debugM $ "HsProc start" - an0 <- markEpAnnL an lidl AnnProc + an0 <- markEpAnnL' an lidl AnnProc p' <- markAnnotated p - an1 <- markEpAnnL an0 lidl AnnRarrow + an1 <- markEpAnnL' an0 lidl AnnRarrow debugM $ "HsProc after AnnRarrow" c' <- markAnnotated c return (HsProc an1 p' c') exact (HsStatic an e) = do - an0 <- markEpAnnL an lidl AnnStatic + an0 <- markEpAnnL' an lidl AnnStatic e' <- markAnnotated e return (HsStatic an0 e') @@ -3357,14 +3280,12 @@ instance ExactPrint (HsPragE GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (HsUntypedSplice GhcPs) where - getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an - getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal + getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor (HsUntypedSpliceExpr an e) anc ts cs = HsUntypedSpliceExpr (setAnchorEpa an anc ts cs) e - setAnnotationAnchor a at HsQuasiQuote {} _ _ _= a + setAnnotationAnchor a _ _ _= a exact (HsUntypedSpliceExpr an e) = do - an0 <- markEpAnnL an lidl AnnDollar + an0 <- markEpAnnL' an lidl AnnDollar e' <- markAnnotated e return (HsUntypedSpliceExpr an0 e') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f0e07d824988133cd70d5020c0e8d6701f94b99 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f0e07d824988133cd70d5020c0e8d6701f94b99 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 Dec 9 13:32:43 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 08:32:43 -0500 Subject: [Git][ghc/ghc][wip/T24124] 124 commits: EPA: print doc comments as normal comments Message-ID: <65746c7b908fa_3478bc2e7b8bfc3321f2@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - c968d405 by Sebastian Graf at 2023-12-09T12:36:11+01:00 CorePrep: Attach evaldUnfolding to floats to detect more values See `Note [Pin evaluatedness on floats]`. - - - - - 0a89c102 by Sebastian Graf at 2023-12-09T14:32:32+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 30 changed files: - .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/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3229473c482e8348c69cd0b241611408d8ae5849...0a89c102cb13221543207bf95987f9c40c4dc432 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3229473c482e8348c69cd0b241611408d8ae5849...0a89c102cb13221543207bf95987f9c40c4dc432 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 Dec 9 13:46:13 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 08:46:13 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <65746fa5bd697_3478bc2efab9e03325ea@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: ceff86ac by Sebastian Graf at 2023-12-09T14:46:02+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,36 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW# magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats] + and Note [Pin evaluatedness on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -179,7 +180,7 @@ with the corresponding name produce a result in that syntax. -} type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' +type AIApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' @@ -841,16 +842,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkNonRecFloat env evalDmd is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -939,14 +962,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1007,9 +1030,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1022,7 +1045,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1032,7 +1055,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1058,24 +1081,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkNonRecFloat env evalDmd is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1122,13 +1157,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1150,12 +1185,12 @@ cpeApp top_env expr rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function + -> AIApp -- The function -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! -- Just stuff floated out from the head of the application. -> [Demand] -> Maybe Arity - -> UniqSM (CpeApp + -> UniqSM (AIApp ,Floats ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] ) @@ -1165,12 +1200,12 @@ cpeApp top_env expr rebuild_app' :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp + -> AIApp -> Floats -> [Demand] -> [CoreTickish] -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) + -> UniqSM (AIApp, Floats, [CoreTickish]) rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info return (app, floats, rt_ticks) @@ -1184,13 +1219,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1199,10 +1234,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1540,7 +1575,7 @@ applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> AIApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr @@ -1719,12 +1754,13 @@ During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a fresh binder `sat`. Now there are two interesting cases: - 1. When `e` is a value, we will float `sat=e` as far as possible, even to - top-level. It is important that we mark `sat` as evaluated (via setting its - unfolding to `evaldUnfolding`), otherwise we get a superfluous thunk to - carry out the field set on T's field, because `exprIsHNF sat == False`: + 1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible, + to top-level, even. It is important that we mark `sat` as evaluated (via + setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous + thunk to carry out the field seq on T's field, because + `exprIsHNF sat == False`: - let sat = e in + let sat = Just y in let sat2 = case sat of x { __DEFAULT } -> T x in -- NONONO, want just `sat2 = T x` f sat2 @@ -1763,6 +1799,27 @@ an `evaldUnfolding` if either 1. `e` is a value, or 2. `sat=e` is case-bound, but won't float to top-level. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b [GblId[DataConWrapper], Arity=2, Str=, Unf=OtherCon []] = {} \r [conrep conrep1] - case conrep of conrep2 { + case conrep of conrep2 [Dmd=SL] { __DEFAULT -> - case conrep1 of conrep3 { + case conrep1 of conrep3 [Dmd=SL] { __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; }; }; @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat [Dmd=SL] { + __DEFAULT -> + case y of conrep [Dmd=SL] { + __DEFAULT -> let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + sat [Occ=Once1, Dmd=SL] :: T15226b.StrictPair a b + [LclId, Unf=OtherCon []] = + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ceff86ac04687b0dc0d75551682b9bd3783aa02e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ceff86ac04687b0dc0d75551682b9bd3783aa02e 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 Dec 9 16:40:26 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 11:40:26 -0500 Subject: [Git][ghc/ghc][wip/T24124] 2 commits: CorePrep: Attach evaldUnfolding to floats to detect more values Message-ID: <6574987aed99c_3478bc32ef40c034366e@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 7e06ea59 by Sebastian Graf at 2023-12-09T17:39:54+01:00 CorePrep: Attach evaldUnfolding to floats to detect more values See `Note [Pin evaluatedness on floats]`. - - - - - 74d67a77 by Sebastian Graf at 2023-12-09T17:39:54+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 9 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/ghci/should_run/T21052.stdout - testsuite/tests/simplCore/should_compile/T23083.stderr - testsuite/tests/simplStg/should_compile/T15226b.stderr - testsuite/tests/simplStg/should_compile/T19717.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,36 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats] + and Note [Pin evaluatedness on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -179,7 +180,7 @@ with the corresponding name produce a result in that syntax. -} type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' +type AIApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' @@ -679,9 +680,11 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float@(Float (NonRec v' _) _ _) = + mkNonRecFloat env topDmd False v rhs2 + -- v' has demand info and possibly evaldUnfolding ; return ( snocFloat floats2 float - , cpeEtaExpand arity (Var v)) }) + , cpeEtaExpand arity (Var v')) }) -- Wrap floating ticks ; let (floats4, rhs4) = wrapTicks floats3 rhs3 @@ -839,16 +842,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkNonRecFloat env evalDmd is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +962,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1005,9 +1030,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1045,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1055,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1081,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkNonRecFloat env evalDmd is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1157,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1148,12 +1185,12 @@ cpeApp top_env expr rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function + -> AIApp -- The function -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! -- Just stuff floated out from the head of the application. -> [Demand] -> Maybe Arity - -> UniqSM (CpeApp + -> UniqSM (AIApp ,Floats ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] ) @@ -1163,12 +1200,12 @@ cpeApp top_env expr rebuild_app' :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp + -> AIApp -> Floats -> [Demand] -> [CoreTickish] -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) + -> UniqSM (AIApp, Floats, [CoreTickish]) rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info return (app, floats, rt_ticks) @@ -1182,13 +1219,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1234,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1484,8 +1521,10 @@ cpeArg env dmd arg else do { v <- newVar arg_ty -- See Note [Eta expansion of arguments in CorePrep] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 - ; return (snocFloat floats2 arg_float, varToCoreExpr v) } + arg_float@(Float (NonRec v' _) _ _) = + mkNonRecFloat env dmd is_unlifted v arg3 + -- v' has demand info and possibly evaldUnfolding + ; return (snocFloat floats2 arg_float, varToCoreExpr v') } } cpeEtaExpandArg :: CorePrepEnv -> CoreArg -> CoreArg @@ -1536,7 +1575,7 @@ applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> AIApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr @@ -1704,6 +1743,83 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Pin evaluatedness on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call to a CBV function, such as a DataCon worker with strict fields: + + data T a = T !a + ... f (T e) ... + +During ANFisation, we will `mkNonRecFloat` for `e`, binding it to a +fresh binder `sat`. +Now there are two interesting cases: + + 1. When `e=Just y` is a value, we will float `sat=Just y` as far as possible, + to top-level, even. It is important that we mark `sat` as evaluated (via + setting its unfolding to `evaldUnfolding`), otherwise we get a superfluous + thunk to carry out the field seq on T's field, because + `exprIsHNF sat == False`: + + let sat = Just y in + let sat2 = case sat of x { __DEFAULT } -> T x in + -- NONONO, want just `sat2 = T x` + f sat2 + + This happened in $walexGetByte, where the thunk caused additional + allocation. + + 2. Similarly, when `e` is not a value, we still know that it is strictly + evaluated. Hence it is going to be case-bound, and we anticipate that `sat` + will be a case binder which is *always* evaluated. + Hence in this case, we also mark `sat` as evaluated via its unfolding. + This happened in GHC.Linker.Deps.$wgetLinkDeps, where without + `evaldUnfolding` we ended up with this: + + Word64Map = ... | Bin ... ... !Word64Map !Word64Map + case ... of { Word64Map.Bin a b l r -> + case insert ... of sat { __DEFAULT -> + case Word64Map.Bin a b l sat of sat2 { __DEFAULT -> + f sat2 + }}} + + Note that *the DataCon app `Bin a b l sat` was case-bound*, because it was + not detected to be a value according to `exprIsHNF`. + That is because the strict field `sat` lacked the `evaldUnfolding`, + although it ended up being case-bound. + + There is one small wrinkle: It could be that `sat=insert ...` floats to + top-level, where it is not eagerly evaluated. In this case, we may not + give `sat` an `evaldUnfolding`. We detect this case by looking at the + `FloatInfo` of `sat=insert ...`: If it says `TopLvlFloatable`, we are + conservative and will not give `sat` an `evaldUnfolding`. + +TLDR; when creating a new float `sat=e` in `mkNonRecFloat`, propagate `sat` with +an `evaldUnfolding` if either + + 1. `e` is a value, or + 2. `sat=e` is case-bound, but won't float to top-level. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments @@ -1986,7 +2102,6 @@ mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ Float (NonRec bndr' rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] (bound,info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the @@ -2017,6 +2132,17 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe + evald = is_hnf || (bound == CaseBound && info /= TopLvlFloatable) + bndr' = pinIdInfo evald dmd bndr + -- See Note [Pin demand info on floats] + -- See Note [Pin evaluatedness on floats] + +pinIdInfo :: Bool -> Demand -> Id -> Id +-- See Note [Pin evaluatedness on floats] +-- See Note [Pin demand info on floats] +pinIdInfo evald dmd = + applyWhen evald (`setIdUnfolding` evaldUnfolding) . (`setIdDemandInfo` dmd) + -- | Wrap floats around an expression wrapBinds :: Floats -> CpeBody -> CpeBody wrapBinds floats body ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/ghci/should_run/T21052.stdout ===================================== @@ -5,7 +5,7 @@ BCO_toplevel :: GHC.Types.IO [GHC.Types.Any] {} \u [] let { sat :: [GHC.Types.Any] - [LclId] = + [LclId, Unf=OtherCon []] = :! [GHC.Tuple.Prim.() GHC.Types.[]]; } in GHC.Base.returnIO sat; ===================================== testsuite/tests/simplCore/should_compile/T23083.stderr ===================================== @@ -14,8 +14,8 @@ T23083.g = \ (f [Occ=Once1!] :: (GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> GHC.Num.Integer.Integer) (h [Occ=OnceL1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer) -> let { sat [Occ=Once1] :: GHC.Num.Integer.Integer -> GHC.Num.Integer.Integer - [LclId] - sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in + [LclId, Unf=OtherCon []] + sat = \ (eta [Occ=Once1] :: GHC.Num.Integer.Integer) -> case h of h1 [Occ=Once1, Dmd=SL] { __DEFAULT -> T23083.$$ @GHC.Num.Integer.Integer @GHC.Num.Integer.Integer h1 eta } } in f sat -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b [GblId[DataConWrapper], Arity=2, Str=, Unf=OtherCon []] = {} \r [conrep conrep1] - case conrep of conrep2 { + case conrep of conrep2 [Dmd=SL] { __DEFAULT -> - case conrep1 of conrep3 { + case conrep1 of conrep3 [Dmd=SL] { __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; }; }; @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat [Dmd=SL] { + __DEFAULT -> + case y of conrep [Dmd=SL] { + __DEFAULT -> let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + sat [Occ=Once1, Dmd=SL] :: T15226b.StrictPair a b + [LclId, Unf=OtherCon []] = + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun ===================================== testsuite/tests/simplStg/should_compile/T19717.stderr ===================================== @@ -3,15 +3,15 @@ Foo.f :: forall {a}. a -> [GHC.Maybe.Maybe a] [GblId, Arity=1, Str=<1L>, Unf=OtherCon []] = {} \r [x] - case x of x1 { + case x of x1 [Dmd=SL] { __DEFAULT -> let { sat [Occ=Once1] :: GHC.Maybe.Maybe a - [LclId] = + [LclId, Unf=OtherCon []] = GHC.Maybe.Just! [x1]; } in let { sat [Occ=Once1] :: [GHC.Maybe.Maybe a] - [LclId] = + [LclId, Unf=OtherCon []] = :! [sat GHC.Types.[]]; } in : [sat sat]; }; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ceff86ac04687b0dc0d75551682b9bd3783aa02e...74d67a774d2c56d5cad5f524dc59e8935fcedae9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ceff86ac04687b0dc0d75551682b9bd3783aa02e...74d67a774d2c56d5cad5f524dc59e8935fcedae9 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 Dec 9 16:43:12 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 11:43:12 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <65749920a712f_3478bc32ef49f8344087@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: f30e6fee by Sebastian Graf at 2023-12-09T17:42:59+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,36 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats] + and Note [Pin evaluatedness on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -179,7 +180,7 @@ with the corresponding name produce a result in that syntax. -} type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' +type AIApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' @@ -839,16 +840,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkNonRecFloat env evalDmd is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +960,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1005,9 +1028,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1043,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1053,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1079,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkNonRecFloat env evalDmd is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1155,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1148,12 +1183,12 @@ cpeApp top_env expr rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function + -> AIApp -- The function -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! -- Just stuff floated out from the head of the application. -> [Demand] -> Maybe Arity - -> UniqSM (CpeApp + -> UniqSM (AIApp ,Floats ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] ) @@ -1163,12 +1198,12 @@ cpeApp top_env expr rebuild_app' :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp + -> AIApp -> Floats -> [Demand] -> [CoreTickish] -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) + -> UniqSM (AIApp, Floats, [CoreTickish]) rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info return (app, floats, rt_ticks) @@ -1182,13 +1217,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1232,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1536,7 +1571,7 @@ applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> AIApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr @@ -1704,6 +1739,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b [GblId[DataConWrapper], Arity=2, Str=, Unf=OtherCon []] = {} \r [conrep conrep1] - case conrep of conrep2 { + case conrep of conrep2 [Dmd=SL] { __DEFAULT -> - case conrep1 of conrep3 { + case conrep1 of conrep3 [Dmd=SL] { __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; }; }; @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat [Dmd=SL] { + __DEFAULT -> + case y of conrep [Dmd=SL] { + __DEFAULT -> let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + sat [Occ=Once1, Dmd=SL] :: T15226b.StrictPair a b + [LclId, Unf=OtherCon []] = + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f30e6fee7709240171c821b30c15098f42dfe1d3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f30e6fee7709240171c821b30c15098f42dfe1d3 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 Dec 9 16:43:52 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 11:43:52 -0500 Subject: [Git][ghc/ghc][wip/T20749] 6 commits: Take care when simplifying unfoldings Message-ID: <6574994811cbd_3478bc32b92fbc3444ea@gitlab.mail> Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 7e06ea59 by Sebastian Graf at 2023-12-09T17:39:54+01:00 CorePrep: Attach evaldUnfolding to floats to detect more values See `Note [Pin evaluatedness on floats]`. - - - - - 12b80370 by Sebastian Graf at 2023-12-09T17:40:27+01:00 Make DataCon workers strict in strict fields (#20749) This patch tweaks `exprIsConApp_maybe`, `exprIsHNF` and friends, and Demand Analysis so that they exploit and maintain strictness of DataCon workers. See `Note [Strict fields in Core]` for details. Very little needed to change, and it puts field seq insertion done by Tag Inference into a new perspective: That of *implementing* strict field semantics. Before Tag Inference, DataCon workers are strict. Afterwards they are effectively lazy and field seqs happen around use sites. History has shown that there is no other way to guarantee taggedness and thus the STG Strict Field Invariant. Knock-on changes: * `exprIsHNF` previously used `exprOkForSpeculation` on unlifted arguments instead of recursing into `exprIsHNF`. That regressed the termination analysis in CPR analysis (which simply calls out to `exprIsHNF`), so I made it call `exprOkForSpeculation`, too. * There's a small regression in Demand Analysis, visible in the changed test output of T16859: Previously, a field seq on a variable would give that variable a "used exactly once" demand, now it's "used at least once", because `dmdTransformDataConSig` accounts for future uses of the field that actually all go through the case binder (and hence won't re-enter the potential thunk). The difference should hardly be observable. * The Simplifier's fast path for data constructors only applies to lazy data constructors now. I observed regressions involving Data.Binary.Put's `Pair` data type. * Unfortunately, T21392 does no longer reproduce after this patch, so I marked it as "not broken" in order to track whether we regress again in the future. Fixes #20749, the satisfying conclusion of an annoying saga (cf. the ideas in #21497 and #22475). Co-Authored-By: Jaro Reinders <jaro.reinders at gmail.com> - - - - - 30 changed files: - compiler/GHC/Builtin/Types.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/CSE.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/TyCl/Build.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Utils/Misc.hs - testsuite/tests/ghci/should_run/T21052.stdout - + testsuite/tests/quantified-constraints/T22238.hs - testsuite/tests/quantified-constraints/all.T - testsuite/tests/simplCore/should_compile/T23083.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fb45f126fdcdfd1e715d998d194254ac1148137...12b80370a82b4191558aef01eb7203035193c0a2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fb45f126fdcdfd1e715d998d194254ac1148137...12b80370a82b4191558aef01eb7203035193c0a2 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 Dec 9 16:48:16 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sat, 09 Dec 2023 11:48:16 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <65749a508c20d_3478bc335172a43452b9@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 29c012d5 by Sebastian Graf at 2023-12-09T17:48:06+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,35 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -179,7 +180,7 @@ with the corresponding name produce a result in that syntax. -} type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' +type AIApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' @@ -839,16 +840,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkNonRecFloat env evalDmd is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +960,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1005,9 +1028,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1043,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1053,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1079,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkNonRecFloat env evalDmd is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1155,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1148,12 +1183,12 @@ cpeApp top_env expr rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function + -> AIApp -- The function -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! -- Just stuff floated out from the head of the application. -> [Demand] -> Maybe Arity - -> UniqSM (CpeApp + -> UniqSM (AIApp ,Floats ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] ) @@ -1163,12 +1198,12 @@ cpeApp top_env expr rebuild_app' :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp + -> AIApp -> Floats -> [Demand] -> [CoreTickish] -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) + -> UniqSM (AIApp, Floats, [CoreTickish]) rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info return (app, floats, rt_ticks) @@ -1182,13 +1217,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1232,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1536,7 +1571,7 @@ applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> AIApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr @@ -1704,6 +1739,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -4,9 +4,9 @@ T15226b.$WMkStrictPair [InlPrag=INLINE[final] CONLIKE] :: forall a b. a %1 -> b %1 -> T15226b.StrictPair a b [GblId[DataConWrapper], Arity=2, Str=, Unf=OtherCon []] = {} \r [conrep conrep1] - case conrep of conrep2 { + case conrep of conrep2 [Dmd=SL] { __DEFAULT -> - case conrep1 of conrep3 { + case conrep1 of conrep3 [Dmd=SL] { __DEFAULT -> T15226b.MkStrictPair [conrep2 conrep3]; }; }; @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat [Dmd=SL] { + __DEFAULT -> + case y of conrep [Dmd=SL] { + __DEFAULT -> let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + sat [Occ=Once1, Dmd=SL] :: T15226b.StrictPair a b + [LclId, Unf=OtherCon []] = + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29c012d542bfa39ceaaa06561ba7e4764109eadd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29c012d542bfa39ceaaa06561ba7e4764109eadd 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 Dec 9 18:27:55 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sat, 09 Dec 2023 13:27:55 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: remove EpAnn from HsParTy and HsFunTy Message-ID: <6574b1ab583b9_3478bc35bd84c4345873@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 5b6a53f9 by Alan Zimmerman at 2023-12-09T18:11:02+00:00 EPA: remove EpAnn from HsParTy and HsFunTy - - - - - 16 changed files: - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/ThToHs.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - utils/check-exact/ExactPrint.hs - utils/haddock Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -351,12 +351,12 @@ type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = EpAnnCO +type instance XFunTy (GhcPass _) = NoExtField type instance XListTy (GhcPass _) = EpAnn AnnParen type instance XTupleTy (GhcPass _) = EpAnn AnnParen type instance XSumTy (GhcPass _) = EpAnn AnnParen type instance XOpTy (GhcPass _) = EpAnn [AddEpAnn] -type instance XParTy (GhcPass _) = EpAnn AnnParen +type instance XParTy (GhcPass _) = AnnParen type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] @@ -615,15 +615,12 @@ splitHsFunType ty = go ty = let (anns, cs, args, res) = splitHsFunType ty anns' = anns ++ annParen2AddEpAnn an - cs' = cs S.<> epAnnComments l S.<> epAnnComments an + cs' = cs S.<> epAnnComments l in (anns', cs', args, res) - go (L ll (HsFunTy (EpAnn _ _ cs) mult x y)) + go (L ll (HsFunTy _ mult x y)) | (anns, csy, args, res) <- splitHsFunType y - = (anns, csy S.<> epAnnComments ll, HsScaled mult x':args, res) - where - L l t = x - x' = L (addCommentsToEpAnn l cs) t + = (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res) go other = ([], emptyComments, [], other) ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -631,7 +631,7 @@ nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLocA (HsAppTy noExtField f t) nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x)) -nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow x) a b) +nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow x) a b) where x = case ghcPass @p of GhcPs -> noAnn ===================================== compiler/GHC/Parser.y ===================================== @@ -2206,17 +2206,15 @@ is connected to the first type too. type :: { LHsType GhcPs } -- See Note [%shift: type -> btype] : btype %shift { $1 } - | btype '->' ctype {% acsA (\cs -> sLL $1 $> - $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) (HsUnrestrictedArrow (epUniTok $2)) $1 $3) } + | btype '->' ctype {% amsA' (sLL $1 $> + $ HsFunTy noExtField (HsUnrestrictedArrow (epUniTok $2)) $1 $3) } | btype mult '->' ctype {% hintLinear (getLoc $2) >> let arr = (unLoc $2) (epUniTok $3) - in acsA (\cs -> sLL $1 $> - $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) arr $1 $4) } + in amsA' (sLL $1 $> $ HsFunTy noExtField arr $1 $4) } | btype '->.' ctype {% hintLinear (getLoc $2) >> - acsA (\cs -> sLL $1 $> - $ HsFunTy (EpAnn (glEE $1 $>) NoEpAnns cs) (HsLinearArrow (EpLolly (epTok $2))) $1 $3) } + amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow (EpLolly (epTok $2))) $1 $3) } -- [mu AnnLollyU $2] } mult :: { Located (EpUniToken "->" "\8594" -> HsArrow GhcPs) } @@ -2281,7 +2279,7 @@ atype :: { LHsType GhcPs } | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) } | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) } | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glEE $1 $>) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) } - | '(' ktype ')' {% acsA (\cs -> sLL $1 $> $ HsParTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $3)) cs) $2) } + | '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (AnnParen AnnParens (glAA $1) (glAA $3)) $2) } | quasiquote { mapLocA (HsSpliceTy noExtField) $1 } | splice_untyped { mapLocA (HsSpliceTy noExtField) $1 } -- see Note [Promotion] for the followings ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -1191,8 +1191,8 @@ widenLocatedAn (EpAnn anc a cs) _as = EpAnn anc a cs epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] epAnnAnns (EpAnn _ anns _) = anns -annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn] -annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _) +annParen2AddEpAnn :: AnnParen -> [AddEpAnn] +annParen2AddEpAnn (AnnParen pt o c) = [AddEpAnn ai o, AddEpAnn ac c] where (ai,ac) = parenTypeKws pt ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -815,15 +815,14 @@ mkGadtDecl loc names dcol ty = do (args, res_ty, annsa, csa) <- case body_ty of - L ll (HsFunTy af hsArr (L _loc' (HsRecTy an rf)) res_ty) -> do - let an' = addCommentsToEpAnn an (comments af) + L ll (HsFunTy _ hsArr (L _loc' (HsRecTy an rf)) res_ty) -> do arr <- case hsArr of HsUnrestrictedArrow arr -> return arr _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ (PsErrIllegalGadtRecordMultiplicity hsArr) return noAnn - return ( RecConGADT arr (L an' rf), res_ty + return ( RecConGADT arr (L an rf), res_ty , [], epAnnComments ll) _ -> do let (anns, cs, arg_types, res_type) = splitHsFunType body_ty @@ -953,11 +952,11 @@ checkTyVars pp_what equals_or_where tc tparms -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) - chkParens ops cps cs bvis (L l (HsParTy an ty)) + chkParens ops cps cs bvis (L l (HsParTy _ ty)) = let (o,c) = mkParensEpAnn (realSrcSpan $ locA l) in - chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) bvis ty + chkParens (o:ops) (c:cps) cs bvis ty chkParens ops cps cs bvis ty = chk ops cps cs bvis ty -- Check that the name space is correct! @@ -1072,10 +1071,10 @@ checkTyClHdr is_cls ty goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix -- workaround to define '*' despite StarIsType - go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix + go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix = do { addPsMessage (locA l) PsWarnStarBinder ; let name = mkOccNameFS tcClsName (starSym isUni) - ; let a' = newAnns l an + ; let a' = newAnns ll l an ; return (L a' (Unqual name), acc, fix , (reverse ops') ++ cps') } @@ -1104,12 +1103,12 @@ checkTyClHdr is_cls ty -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName - newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN - newAnns (EpAnn ap (AnnListItem ta) csp) (EpAnn as (AnnParen _ o c) cs) = + newAnns :: SrcSpan -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN + newAnns l (EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) = let - lr = RealSrcSpan (combineRealSrcSpans (anchor ap) (anchor as)) Strict.Nothing + lr = combineSrcSpans (RealSrcSpan (anchor ap) Strict.Nothing) l in - EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) (csp Semi.<> cs) + EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) csp -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. @@ -1170,10 +1169,7 @@ checkContext orig_t@(L (EpAnn l _ _) _orig_t) = check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) -- to be sure HsParTy doesn't get into the way - = do - let (op,cp,cs') = case ann' of - EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs) - check (op++opi,cp++cpi,cs' Semi.<> csi) ty + = check (ap_open ann':opi, ap_close ann':cpi, csi) ty -- No need for anns, returning original check (_opi,_cpi,_csi) _t = ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -1378,14 +1378,14 @@ tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (tcMkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) + ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (tcMkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1642,7 +1642,7 @@ cvtTypeKind typeOrKind ty _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnLA (HsFunTy noAnn (HsUnrestrictedArrow noAnn) x'' y'') + returnLA (HsFunTy noExtField (HsUnrestrictedArrow noAnn) x'' y'') | otherwise -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } @@ -1657,7 +1657,7 @@ cvtTypeKind typeOrKind ty parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' w'' = hsTypeToArrow w' - returnLA (HsFunTy noAnn w'' x'' y'') + returnLA (HsFunTy noExtField w'' x'' y'') | otherwise -> do { fun_tc <- returnLA $ getRdrName fUNTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -219,14 +219,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { Test20239.hs:7:50-86 }) - (AnnParen - (AnnParens) - (EpaSpan { Test20239.hs:7:50 }) - (EpaSpan { Test20239.hs:7:86 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:7:50 }) + (EpaSpan { Test20239.hs:7:86 })) (L (EpAnn (EpaSpan { Test20239.hs:7:51-85 }) @@ -235,11 +231,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { Test20239.hs:7:51-85 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { Test20239.hs:7:62-63 }) @@ -307,14 +299,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { Test20239.hs:7:68-85 }) - (AnnParen - (AnnParens) - (EpaSpan { Test20239.hs:7:68 }) - (EpaSpan { Test20239.hs:7:85 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:7:68 }) + (EpaSpan { Test20239.hs:7:85 })) (L (EpAnn (EpaSpan { Test20239.hs:7:69-84 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -135,11 +135,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { T17544.hs:6:9-16 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { T17544.hs:6:11-12 }) @@ -318,11 +314,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { T17544.hs:10:9-16 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { T17544.hs:10:11-12 }) @@ -499,11 +491,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { T17544.hs:14:9-16 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { T17544.hs:14:11-12 }) @@ -683,11 +671,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { T17544.hs:18:9-16 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { T17544.hs:18:11-12 }) @@ -782,11 +766,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { T17544.hs:20:9-16 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { T17544.hs:20:11-12 }) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -235,11 +235,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:9:16-27 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:9:20-21 }) @@ -362,14 +358,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:10-17 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:11:10 }) - (EpaSpan { DumpParsedAst.hs:11:17 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:11:10 }) + (EpaSpan { DumpParsedAst.hs:11:17 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:11-16 }) @@ -480,14 +472,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:26-36 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:11:26 }) - (EpaSpan { DumpParsedAst.hs:11:36 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:11:26 }) + (EpaSpan { DumpParsedAst.hs:11:36 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:27-35 }) @@ -864,14 +852,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:25-29 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:15:25 }) - (EpaSpan { DumpParsedAst.hs:15:29 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:15:25 }) + (EpaSpan { DumpParsedAst.hs:15:29 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:15:26-28 }) @@ -973,11 +957,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:12-35 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:17:14-15 }) @@ -1013,11 +993,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:17-35 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:17:29-30 }) @@ -1030,14 +1006,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:17-27 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:17:17 }) - (EpaSpan { DumpParsedAst.hs:17:27 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:17:17 }) + (EpaSpan { DumpParsedAst.hs:17:27 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:17:18-26 }) @@ -1046,11 +1018,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:18-26 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:17:20-21 }) @@ -1462,11 +1430,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:31-39 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:18:33-34 }) @@ -1600,11 +1564,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:20-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:21:22-23 }) @@ -1640,11 +1600,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:25-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:21:27-28 }) @@ -1738,14 +1694,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:22-37 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:22:22 }) - (EpaSpan { DumpParsedAst.hs:22:37 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:22:22 }) + (EpaSpan { DumpParsedAst.hs:22:37 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:22:23-36 }) @@ -1790,11 +1742,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:28-36 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:22:30-31 }) @@ -1859,11 +1807,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:42-60 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:22:54-55 }) @@ -1876,14 +1820,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:42-52 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:22:42 }) - (EpaSpan { DumpParsedAst.hs:22:52 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:22:42 }) + (EpaSpan { DumpParsedAst.hs:22:52 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:22:43-51 }) @@ -1892,11 +1832,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:43-51 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:22:45-46 }) @@ -2024,14 +1960,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:10-34 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpParsedAst.hs:23:10 }) - (EpaSpan { DumpParsedAst.hs:23:34 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpParsedAst.hs:23:10 }) + (EpaSpan { DumpParsedAst.hs:23:34 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:23:11-33 }) @@ -2080,11 +2012,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:22-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpParsedAst.hs:23:27-28 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -297,14 +297,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:11-16 }) @@ -411,14 +407,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:27-35 }) @@ -674,11 +666,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:11:16-27 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -789,11 +777,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:16:20-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -826,11 +810,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:16:25-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -917,14 +897,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:19:23-36 }) @@ -968,11 +944,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:19:28-36 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -1033,11 +1005,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:19:42-60 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -1048,14 +1016,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:19:43-51 }) @@ -1064,11 +1028,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:19:43-51 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -1189,14 +1149,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:20:11-33 }) @@ -1244,11 +1200,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:20:22-33 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -1583,14 +1535,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:22:26-28 }) @@ -1971,11 +1919,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:25:31-39 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -2091,11 +2035,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:24:12-35 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -2128,11 +2068,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:24:17-35 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L @@ -2143,14 +2079,10 @@ (EpaComments [])) (HsParTy - (EpAnn + (AnnParen + (AnnParens) (EpaDelta (SameLine 0) []) - (AnnParen - (AnnParens) - (EpaDelta (SameLine 0) []) - (EpaDelta (SameLine 0) [])) - (EpaComments - [])) + (EpaDelta (SameLine 0) [])) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:24:18-26 }) @@ -2159,11 +2091,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:24:18-26 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (NoExtField)) (L ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1431,11 +1431,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpSemis.hs:29:12-23 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpSemis.hs:29:18-19 }) @@ -1672,11 +1668,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { DumpSemis.hs:31:25-30 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { DumpSemis.hs:31:27-28 }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -883,11 +883,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { KindSigs.hs:22:8-44 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { KindSigs.hs:22:22-23 }) @@ -900,14 +896,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { KindSigs.hs:22:8-20 }) - (AnnParen - (AnnParens) - (EpaSpan { KindSigs.hs:22:8 }) - (EpaSpan { KindSigs.hs:22:20 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { KindSigs.hs:22:8 }) + (EpaSpan { KindSigs.hs:22:20 })) (L (EpAnn (EpaSpan { KindSigs.hs:22:9-19 }) @@ -975,11 +967,7 @@ (EpaComments [])) (HsFunTy - (EpAnn - (EpaSpan { KindSigs.hs:22:25-44 }) - (NoEpAnns) - (EpaComments - [])) + (NoExtField) (HsUnrestrictedArrow (EpUniTok (EpaSpan { KindSigs.hs:22:30-31 }) @@ -1015,14 +1003,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { KindSigs.hs:22:33-44 }) - (AnnParen - (AnnParens) - (EpaSpan { KindSigs.hs:22:33 }) - (EpaSpan { KindSigs.hs:22:44 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { KindSigs.hs:22:33 }) + (EpaSpan { KindSigs.hs:22:44 })) (L (EpAnn (EpaSpan { KindSigs.hs:22:34-43 }) @@ -1785,14 +1769,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { KindSigs.hs:34:9-22 }) - (AnnParen - (AnnParens) - (EpaSpan { KindSigs.hs:34:9 }) - (EpaSpan { KindSigs.hs:34:22 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { KindSigs.hs:34:9 }) + (EpaSpan { KindSigs.hs:34:22 })) (L (EpAnn (EpaSpan { KindSigs.hs:34:10-21 }) ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -179,14 +179,10 @@ (EpaComments [])) (HsParTy - (EpAnn - (EpaSpan { T15323.hs:6:31-36 }) - (AnnParen - (AnnParens) - (EpaSpan { T15323.hs:6:31 }) - (EpaSpan { T15323.hs:6:36 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { T15323.hs:6:31 }) + (EpaSpan { T15323.hs:6:36 })) (L (EpAnn (EpaSpan { T15323.hs:6:32-35 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -926,6 +926,20 @@ markParen (EpAnn anc (AnnParen pt o c) cs) l = do kw AnnParensHash = (AnnOpenPH, AnnClosePH) kw AnnParensSquare = (AnnOpenS, AnnCloseS) +markOpeningParen', markClosingParen' :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markOpeningParen' an = markParen' an lfst +markClosingParen' an = markParen' an lsnd + +markParen' :: (Monad m, Monoid w) => AnnParen -> (forall a. Lens (a,a) a) -> EP w m AnnParen +markParen' (AnnParen pt o c) l = do + loc' <- markKwA (view l $ kw pt) (view l (o, c)) + let (o',c') = set l loc' (o,c) + return (AnnParen pt o' c') + where + kw AnnParens = (AnnOpenP, AnnCloseP) + kw AnnParensHash = (AnnOpenPH, AnnClosePH) + kw AnnParensSquare = (AnnOpenS, AnnCloseS) + -- --------------------------------------------------------------------- -- Bare bones Optics -- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html @@ -4029,12 +4043,12 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsTyVar an _ _) = fromAnn an getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal - getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an + getAnnotationEntry (HsFunTy _ _ _ _) = NoEntryVal getAnnotationEntry (HsListTy an _) = fromAnn an getAnnotationEntry (HsTupleTy an _ _) = fromAnn an getAnnotationEntry (HsSumTy an _) = fromAnn an getAnnotationEntry (HsOpTy an _ _ _ _) = fromAnn an - getAnnotationEntry (HsParTy an _) = fromAnn an + getAnnotationEntry (HsParTy _ _) = NoEntryVal getAnnotationEntry (HsIParamTy an _ _) = fromAnn an getAnnotationEntry (HsStarTy _ _) = NoEntryVal getAnnotationEntry (HsKindSig an _ _) = fromAnn an @@ -4053,12 +4067,12 @@ instance ExactPrint (HsType GhcPs) where setAnnotationAnchor (HsTyVar an a b) anc ts cs = (HsTyVar (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _ _s = a - setAnnotationAnchor (HsFunTy an a b c) anc ts cs = (HsFunTy (setAnchorEpa an anc ts cs) a b c) + setAnnotationAnchor a@(HsFunTy{}) _ _ _s = a setAnnotationAnchor (HsListTy an a) anc ts cs = (HsListTy (setAnchorEpa an anc ts cs) a) setAnnotationAnchor (HsTupleTy an a b) anc ts cs = (HsTupleTy (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor (HsSumTy an a) anc ts cs = (HsSumTy (setAnchorEpa an anc ts cs) a) setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _ _s = a - setAnnotationAnchor (HsParTy an a) anc ts cs = (HsParTy (setAnchorEpa an anc ts cs) a) + setAnnotationAnchor a@(HsParTy{}) _ _ _s = a setAnnotationAnchor (HsIParamTy an a b) anc ts cs = (HsIParamTy (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsStarTy _ _) _ _ _s = a setAnnotationAnchor (HsKindSig an a b) anc ts cs = (HsKindSig (setAnchorEpa an anc ts cs) a b) @@ -4127,9 +4141,9 @@ instance ExactPrint (HsType GhcPs) where t2' <- markAnnotated t2 return (HsOpTy an0 promoted t1' lo' t2') exact (HsParTy an ty) = do - an0 <- markOpeningParen an + an0 <- markOpeningParen' an ty' <- markAnnotated ty - an1 <- markClosingParen an0 + an1 <- markClosingParen' an0 return (HsParTy an1 ty') exact (HsIParamTy an n t) = do n' <- markAnnotated n ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit 579df3aa57a9c49b555dbb0feb607b73aa695284 +Subproject commit bbc5ab1bc4c2d064e3dd5f7413f527d57b53a6b1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b6a53f9e5325e5095f1e910bdc2a1f17f99ae96 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b6a53f9e5325e5095f1e910bdc2a1f17f99ae96 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 Dec 10 00:44:15 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Sat, 09 Dec 2023 19:44:15 -0500 Subject: [Git][ghc/ghc][wip/DataToTagSmallOp] 7 commits: apply SPJ's suggestion for DTW4 and DTW5 Message-ID: <657509df27ccd_3478bc3e1b5f7438642a@gitlab.mail> Matthew Craven pushed to branch wip/DataToTagSmallOp at Glasgow Haskell Compiler / GHC Commits: 7d546cc8 by Matthew Craven at 2023-12-09T19:20:32-05:00 apply SPJ's suggestion for DTW4 and DTW5 - - - - - 84cb27f9 by Matthew Craven at 2023-12-09T19:21:33-05:00 Re-flow text in DTW4 - - - - - 018153f4 by Matthew Craven at 2023-12-09T19:28:17-05:00 Fiddle with DTW4 some more - - - - - 02805af6 by Matthew Craven at 2023-12-09T19:30:26-05:00 Refer to DTW4 from the "Each evaluates" bullet - - - - - 336bd549 by Matthew Craven at 2023-12-09T19:34:42-05:00 Name the "special handling" bullets - - - - - cb0f5620 by Matthew Craven at 2023-12-09T19:40:19-05:00 Refer to DTT3 from DTW5 - - - - - de1c039c by Matthew Craven at 2023-12-09T19:43:32-05:00 Update wrinkle DTW6 - - - - - 2 changed files: - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/Tc/Instance/Class.hs Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -75,7 +75,7 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = -- dataToTagSmall# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class, --- particularly wrinkle DTW4 +-- particularly wrinkles H3 and DTW4 cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagSmall#") @@ -90,7 +90,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class, --- particularly wrinkle DTW4 +-- particularly wrinkles H3 and DTW4 cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -716,17 +716,23 @@ these conditions: These two primops have special handling in several parts of the compiler: -- They have a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing their results. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- Each evaluates its argument; this is implemented via special cases in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -784,30 +790,42 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) The way tag information is stored at runtime is described in +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, for "big data types" we must consult the heap object's info table at - least in the MAX_PTR_TAG case, while for "small data types" we can - always just examine the tag bits on the pointer itself. - - Although it is always correct to consult the info table, we can - produce slightly smaller and faster code by not doing so for "small - data types." Since types and coercions are largely erased in STG, - the simplest reliable way to achieve this is to produce different - primops in DataToTag instances depending on the number of data - constructors the relevant TyCon has. - -(DTW5) We consider a call `dataToTagSmall# x` to result in undefined - behavior whenever the target supports pointer tagging but the actual - constructor index for `x` is too large to fit in the pointer's tag - bits. Otherwise, `dataToTagSmall#` behaves identically to - `dataToTagLarge#`. + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back te examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. This allows the rewrites performed in GHC.Core.Opt.ConstantFold to safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: the allowed program behaviors for the former is always a superset of the allowed program behaviors for the latter. + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + (DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. @@ -815,11 +833,12 @@ Wrinkles: original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. (DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim contains the following non-sense definitions: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82795106afb05801c8220c6cc81e667d37303381...de1c039cbf4ed8bb07d33fb0768e55a8e79ef3fd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82795106afb05801c8220c6cc81e667d37303381...de1c039cbf4ed8bb07d33fb0768e55a8e79ef3fd 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 Dec 10 00:48:19 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Sat, 09 Dec 2023 19:48:19 -0500 Subject: [Git][ghc/ghc][wip/DataToTagSmallOp] 2 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <65750ad325909_3478bc3e80d3683868e7@gitlab.mail> Matthew Craven pushed to branch wip/DataToTagSmallOp at Glasgow Haskell Compiler / GHC Commits: 1504301b by Matthew Craven at 2023-12-09T19:45:22-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 - - - - - bfbd33d9 by Matthew Craven at 2023-12-09T19:47:47-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 17 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,8 +1131,8 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of dataToTagLarge# satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- -- Ignores applications not headed by dataToTagLarge#. @@ -1142,12 +1142,17 @@ checkDataToTagPrimOpTyCon -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -638,9 +634,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -851,6 +848,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,37 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim + While the dataToTag# primops remain exposed from GHC.Prim (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +743,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +763,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +790,91 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back te examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169 and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +900,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +913,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de1c039cbf4ed8bb07d33fb0768e55a8e79ef3fd...bfbd33d9a3af8c2866d1215937957a0a0c4d1457 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/de1c039cbf4ed8bb07d33fb0768e55a8e79ef3fd...bfbd33d9a3af8c2866d1215937957a0a0c4d1457 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 Dec 10 10:32:42 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 10 Dec 2023 05:32:42 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <657593ca4a8b_3478bc4bf9a4e83953cb@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 97c2463f by Sebastian Graf at 2023-12-10T11:32:27+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. Fixes #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,35 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -179,7 +180,7 @@ with the corresponding name produce a result in that syntax. -} type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' +type AIApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' @@ -839,16 +840,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +960,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1005,9 +1028,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1043,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1053,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1079,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1155,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1148,12 +1183,12 @@ cpeApp top_env expr rebuild_app :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function + -> AIApp -- The function -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! -- Just stuff floated out from the head of the application. -> [Demand] -> Maybe Arity - -> UniqSM (CpeApp + -> UniqSM (AIApp ,Floats ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] ) @@ -1163,12 +1198,12 @@ cpeApp top_env expr rebuild_app' :: CorePrepEnv -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp + -> AIApp -> Floats -> [Demand] -> [CoreTickish] -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) + -> UniqSM (AIApp, Floats, [CoreTickish]) rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info return (app, floats, rt_ticks) @@ -1182,13 +1217,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1232,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1536,7 +1571,7 @@ applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> AIApp -> Int -> [CoreTickish] -> UniqSM CpeRhs maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr @@ -1704,6 +1739,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments @@ -1982,12 +2038,27 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + -- See the comments in mkNonRecFloat for the classification + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + | is_data_con bndr = (LetBound, TopLvlFloatable) + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + is_data_con = isJust . isDataConId_maybe + mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ Float (NonRec bndr' rhs) bound info where bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2012,7 +2083,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd + is_strict = isStrUsedDmd dmd || isEvaldUnfolding (idUnfolding bndr) ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97c2463f2499cdff416bb59f4a02029cb481229e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97c2463f2499cdff416bb59f4a02029cb481229e 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 Dec 10 10:42:03 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 10 Dec 2023 05:42:03 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <657595fb81ce6_3478bc4c22229c400013@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 041da341 by Sebastian Graf at 2023-12-10T11:34:07+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`. Fixes #24252. Fixes #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,35 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -167,7 +168,7 @@ Here is the syntax of the Core produced by CorePrep: Expressions body ::= app | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body + | case body of pat -> body | /\a. body | /\c. body | body |> co @@ -839,16 +840,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +960,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1009,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1028,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1043,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1053,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1079,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1155,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1217,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1232,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1704,6 +1739,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments @@ -1982,12 +2038,27 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + -- See the comments in mkNonRecFloat for the classification + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + | is_data_con bndr = (LetBound, TopLvlFloatable) + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + is_data_con = isJust . isDataConId_maybe + mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ Float (NonRec bndr' rhs) bound info where bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2012,7 +2083,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd + is_strict = isStrUsedDmd dmd || isEvaldUnfolding (idUnfolding bndr) ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/041da341e39d9ae762c80895f5a9728e1f5688b8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/041da341e39d9ae762c80895f5a9728e1f5688b8 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 Dec 10 10:42:34 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 10 Dec 2023 05:42:34 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <6575961a6b67b_3478bc4c22229c4004df@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 618fdb24 by Sebastian Graf at 2023-12-10T11:41:56+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,35 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -167,7 +168,7 @@ Here is the syntax of the Core produced by CorePrep: Expressions body ::= app | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body + | case body of pat -> body | /\a. body | /\c. body | body |> co @@ -839,16 +840,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +960,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1009,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1028,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1043,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1053,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1079,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1155,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1217,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1232,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1704,6 +1739,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments @@ -1982,12 +2038,27 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + -- See the comments in mkNonRecFloat for the classification + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + | is_data_con bndr = (LetBound, TopLvlFloatable) + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + is_data_con = isJust . isDataConId_maybe + mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ Float (NonRec bndr' rhs) bound info where bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2012,7 +2083,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd + is_strict = isStrUsedDmd dmd || isEvaldUnfolding (idUnfolding bndr) ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/618fdb24de5bf46d259e8f8eb3aafae49104f035 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/618fdb24de5bf46d259e8f8eb3aafae49104f035 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 Dec 10 10:51:04 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Sun, 10 Dec 2023 05:51:04 -0500 Subject: [Git][ghc/ghc][wip/int-index/rta-docs] docs: update information on RequiredTypeArguments Message-ID: <6575981874ad7_3478bc4c624430402370@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/rta-docs at Glasgow Haskell Compiler / GHC Commits: 3316b7be by Vladislav Zavialov at 2023-12-10T13:50:52+03: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. - - - - - 3 changed files: - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst Changes: ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,33 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2441,21 +2441,17 @@ of ``-W(no-)*``. :since: 9.8.1 - In accordance with `GHC Proposal #281 - `__, - a new extension ``RequiredTypeArguments`` will be introduced in a future GHC release. - - Under ``RequiredTypeArguments``, implicit quantification of type variables does not take place + Under :extension:`RequiredTypeArguments`, implicit quantification of type variables does not take place if there is a term variable of the same name in scope. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification - that would stop working under ``RequiredTypeArguments``. + that would stop working under :extension:`RequiredTypeArguments`. .. ghc-flag:: -Wmissing-role-annotations :shortdesc: warn when type declarations don't have role annotations View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3316b7be5ee0d23f3da3edc3d9f446e7be560dd5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3316b7be5ee0d23f3da3edc3d9f446e7be560dd5 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 Dec 10 10:53:43 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Sun, 10 Dec 2023 05:53:43 -0500 Subject: [Git][ghc/ghc][wip/T24124] Lower seq# early, in CorePrep (#24124) Message-ID: <657598b7b0422_3478bc4c6fb4f840461e@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: a945a4b5 by Sebastian Graf at 2023-12-10T11:53:32+01:00 Lower seq# early, in CorePrep (#24124) We can save many explanations in Tag Inference and StgToCmm in doing so. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 6 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/StgToCmm/Expr.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3646,6 +3646,7 @@ primop SeqOp "seq#" GenPrimOp with effect = ThrowsException work_free = True -- seq# does work iff its lifted arg does work + -- no strictness signature: See Note [seq# magic], (SEQ2) primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -2054,7 +2054,8 @@ The semantics of seq# is Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Why do we need a primop at all? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,7 +2070,16 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd +(SEQ2) + `seq#` evaluates its argument, but does /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as @@ -2080,14 +2090,35 @@ Implementing seq#. The compiler has magic for SeqOp in - GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Lower seq# to a Case, e.g., + + case seq# (f 13) s of (# s', r #) -> rhs + ==> + case f 13 of sat of __DEFAULT -> rhs[sat/r,s/s'] + + this is implemented in two steps, not unlike Note [runRW magic], but + unfortunately not entirely local to `cpeApp`: + + 1. In `cpeApp`, lower the application + seq# (f 13) s + ==> + case f 13 of sat __DEFAULT -> (# s, sat #) + 2. In `cpeRhsE Case{}`, catch the opportunity for beta reducing + case (# s, sat #) of (# s', r #) -> rhs + ==> + rhs[sat/r,s/s'] + + While (2) would be done by Unarise, it is not optional, because + substituting here allows us to carry over demand info and evaluatedness + to detect more values in `rhs`; see Note [Pin demand info on floats]. + + Note that CorePrep really allocates a strict Float for `f 13`. + That's OK, because the telescope of Floats always stays in the same order, + so all guarantees of evaluation order provided by seq# are upheld. -} seqRule :: RuleM CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Unit import GHC.Builtin.Names import GHC.Builtin.Types +import GHC.Builtin.PrimOps import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -159,7 +160,7 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions arg ::= lit | var | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + | arg co | /\c. arg | arg |> co Applications app ::= lit | var | app arg | app ty | app co | app |> co @@ -167,7 +168,7 @@ Here is the syntax of the Core produced by CorePrep: Expressions body ::= app | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body + | case body of pat -> body | /\a. body | /\c. body | body |> co @@ -304,6 +305,12 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite important that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats in the first place; for that it +would have to do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -839,16 +846,38 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con bs _]) cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut + -- See Note [seq# magic]. This is step (2) for CorePrep + ; case alts of + [Alt (DataAlt dc) [token,thing] rhs] + | isTupleDataCon dc + , isDeadBinder bndr + , Var v `App` Type{} `App` Type{} `App` Type{} `App` Type{} `App` Var token' `App` Var thing' <- scrut' + , Just dc' <- isDataConWorkId_maybe v, dc' == dc + -> do { rhs' <- cpeBodyNF (extendCorePrepEnvList env [(token,token'), (thing,thing')]) rhs + ; return (floats, rhs') } + _ -> do { + -- End of seq# magic ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = mightBeUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -- evalDmd states that this is a strict float + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') }} where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +966,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1015,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1034,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1049,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1059,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1085,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | PrimOpId SeqOp _ <- idDetails f + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1161,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1223,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1238,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1704,6 +1745,27 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program involving seq#: + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + ==> {ANFise, lowering seq# as in Note [seq# magic]} + ... case (case x of y { __DEFAULT -> T y }) of sat { __DEFAULT -> rhs[s/s',sat/x'] } + +(Why didn't the Simplifier float out `case x of y`? Because `seq#` is lazy; +see Note [seq# magic].) +Note the case-of-case. This is not bad per sé, but we can easily flatten +this situation by calling `mkNonRecFloat` to create strict binding `y=x`: + + ... case x of y { __DEFAULT -> let sat = T y in rhs[s/s',sat/x'] } ... + +where `T y` is simply let-bound, thus far less likely to confuse passes +downstream. We simply achieve this by calling `mkNonRecFloat` in the `Case` +equation of `cpeRhsE` to create a strict float (`evalDmd`). This mirrors what we +do for let-bindings, when we create a LetBound float: see `cpeBind`. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Since call-by-value is much cheaper than call-by-need, we case-bind arguments @@ -1982,12 +2044,27 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + -- See the comments in mkNonRecFloat for the classification + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + | is_data_con bndr = (LetBound, TopLvlFloatable) + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + is_data_con = isJust . isDataConId_maybe + mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ Float (NonRec bndr' rhs) bound info where bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2012,7 +2089,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd + is_strict = isStrUsedDmd dmd || isEvaldUnfolding (idUnfolding bndr) ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) is_data_con = isJust . isDataConId_maybe ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,7 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. - -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -19,16 +19,16 @@ T15226b.testFun1 -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) [GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a945a4b5c18b36b97a60ed05b35fc403b9dd2e06 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a945a4b5c18b36b97a60ed05b35fc403b9dd2e06 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 Dec 10 14:00:11 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sun, 10 Dec 2023 09:00:11 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove EpAnn from most HsType extension points Message-ID: <6575c46b704d5_3478bc50c4e97441269c@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 86960e06 by Alan Zimmerman at 2023-12-10T13:59:16+00:00 EPA: Remove EpAnn from most HsType extension points Just a few tricky ones left, coming next - - - - - 12 changed files: - compiler/GHC/Hs/Type.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -352,12 +352,12 @@ type instance XQualTy (GhcPass _) = NoExtField type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] type instance XAppTy (GhcPass _) = NoExtField type instance XFunTy (GhcPass _) = NoExtField -type instance XListTy (GhcPass _) = EpAnn AnnParen -type instance XTupleTy (GhcPass _) = EpAnn AnnParen -type instance XSumTy (GhcPass _) = EpAnn AnnParen -type instance XOpTy (GhcPass _) = EpAnn [AddEpAnn] +type instance XListTy (GhcPass _) = AnnParen +type instance XTupleTy (GhcPass _) = AnnParen +type instance XSumTy (GhcPass _) = AnnParen +type instance XOpTy (GhcPass _) = [AddEpAnn] type instance XParTy (GhcPass _) = AnnParen -type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] +type instance XIParamTy (GhcPass _) = [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] @@ -372,7 +372,7 @@ type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = [AddEpAnn] type instance XBangTy (GhcPass _) = [AddEpAnn] -type instance XRecTy GhcPs = EpAnn AnnList +type instance XRecTy GhcPs = AnnList type instance XRecTy GhcRn = NoExtField type instance XRecTy GhcTc = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -2174,7 +2174,7 @@ ctype :: { LHsType GhcPs } , hst_xqual = NoExtField , hst_body = $3 })) } - | ipvar '::' ctype {% acsA (\cs -> sLL $1 $> (HsIParamTy (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) (reLoc $1) $3)) } + | ipvar '::' ctype {% amsA' (sLL $1 $> (HsIParamTy [mu AnnDcolon $2] (reLoc $1) $3)) } | type { $1 } ---------------------- @@ -2267,18 +2267,18 @@ atype :: { LHsType GhcPs } | PREFIX_TILDE atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnTilde $1] SrcLazy $2)) } | PREFIX_BANG atype {% amsA' (sLL $1 $> (mkBangTy [mj AnnBang $1] SrcStrict $2)) } - | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glEE $1 $>) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2)) + | '{' fielddecls '}' {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) $2) ; checkRecordSyntax decls }} -- Constructor sigs only - | '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $2)) cs) + | '(' ')' {% amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParens (glAA $1) (glAA $2)) HsBoxedOrConstraintTuple []) } | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3) - ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParens (glAA $1) (glAA $5)) cs) + ; amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParens (glAA $1) (glAA $5)) HsBoxedOrConstraintTuple (h : $4)) }} - | '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) } - | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) } - | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glEE $1 $>) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) } - | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glEE $1 $>) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) } + | '(#' '#)' {% amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glAA $1) (glAA $2)) HsUnboxedTuple []) } + | '(#' comma_types1 '#)' {% amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glAA $1) (glAA $3)) HsUnboxedTuple $2) } + | '(#' bar_types2 '#)' {% amsA' (sLL $1 $> $ HsSumTy (AnnParen AnnParensHash (glAA $1) (glAA $3)) $2) } + | '[' ktype ']' {% amsA' (sLL $1 $> $ HsListTy (AnnParen AnnParensSquare (glAA $1) (glAA $3)) $2) } | '(' ktype ')' {% amsA' (sLL $1 $> $ HsParTy (AnnParen AnnParens (glAA $1) (glAA $3)) $2) } | quasiquote { mapLocA (HsSpliceTy noExtField) $1 } | splice_untyped { mapLocA (HsSpliceTy noExtField) $1 } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -815,14 +815,14 @@ mkGadtDecl loc names dcol ty = do (args, res_ty, annsa, csa) <- case body_ty of - L ll (HsFunTy _ hsArr (L _loc' (HsRecTy an rf)) res_ty) -> do + L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do arr <- case hsArr of HsUnrestrictedArrow arr -> return arr _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ (PsErrIllegalGadtRecordMultiplicity hsArr) return noAnn - return ( RecConGADT arr (L an rf), res_ty + return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty , [], epAnnComments ll) _ -> do let (anns, cs, arg_types, res_type) = splitHsFunType body_ty @@ -1160,12 +1160,9 @@ checkContext orig_t@(L (EpAnn l _ _) _orig_t) = -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. -- Ditto () - = do - let (op,cp,cs') = case ann' of - EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) - return (L (EpAnn l - -- Append parens so that the original order in the source is maintained - (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) ts) + = return (L (EpAnn l + -- Append parens so that the original order in the source is maintained + (AnnContext Nothing (oparens ++ [ap_open ann']) (ap_close ann':cparens)) cs) ts) check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) -- to be sure HsParTy doesn't get into the way @@ -2034,8 +2031,8 @@ dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs -- Detect when the record syntax is used: -- data T = MkT { ... } dataConBuilderDetails (PrefixDataConBuilder flds _) - | [L _ (HsRecTy an fields)] <- toList flds - = RecCon (L an fields) + | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds + = RecCon (L (EpAnn anc an cs) fields) -- Normal prefix constructor, e.g. data T = MkT A B C dataConBuilderDetails (PrefixDataConBuilder flds _) ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -375,14 +375,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { Test20239.hs:7:83-84 }) - (AnnParen - (AnnParens) - (EpaSpan { Test20239.hs:7:83 }) - (EpaSpan { Test20239.hs:7:84 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { Test20239.hs:7:83 }) + (EpaSpan { Test20239.hs:7:84 })) (HsBoxedOrConstraintTuple) [])))))))))))))]) (Nothing)))]) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -247,14 +247,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { T17544_kw.hs:19:18-19 }) - (AnnParen - (AnnParens) - (EpaSpan { T17544_kw.hs:19:18 }) - (EpaSpan { T17544_kw.hs:19:19 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { T17544_kw.hs:19:18 }) + (EpaSpan { T17544_kw.hs:19:19 })) (HsBoxedOrConstraintTuple) [])))]) (L ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -248,14 +248,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:9:16-18 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpParsedAst.hs:9:16 }) - (EpaSpan { DumpParsedAst.hs:9:18 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpParsedAst.hs:9:16 }) + (EpaSpan { DumpParsedAst.hs:9:18 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:9:17 }) @@ -370,11 +366,7 @@ (EpaComments [])) (HsOpTy - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -640,14 +632,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpParsedAst.hs:10:27-29 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpParsedAst.hs:10:27 }) - (EpaSpan { DumpParsedAst.hs:10:29 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpParsedAst.hs:10:27 }) + (EpaSpan { DumpParsedAst.hs:10:29 })) (L (EpAnn (EpaSpan { DumpParsedAst.hs:10:28 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -309,11 +309,7 @@ (EpaComments [])) (HsOpTy - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -567,14 +563,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:12:27-29 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpRenamedAst.hs:12:27 }) - (EpaSpan { DumpRenamedAst.hs:12:29 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpRenamedAst.hs:12:27 }) + (EpaSpan { DumpRenamedAst.hs:12:29 })) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:12:28 }) @@ -677,14 +669,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:11:16-18 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpRenamedAst.hs:11:16 }) - (EpaSpan { DumpRenamedAst.hs:11:18 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpRenamedAst.hs:11:16 }) + (EpaSpan { DumpRenamedAst.hs:11:18 })) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:11:17 }) @@ -2358,14 +2346,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:31:12-14 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpRenamedAst.hs:31:12 }) - (EpaSpan { DumpRenamedAst.hs:31:14 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpRenamedAst.hs:31:12 }) + (EpaSpan { DumpRenamedAst.hs:31:14 })) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:31:13 }) @@ -2430,14 +2414,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { DumpRenamedAst.hs:32:10-12 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { DumpRenamedAst.hs:32:10 }) - (EpaSpan { DumpRenamedAst.hs:32:12 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { DumpRenamedAst.hs:32:10 }) + (EpaSpan { DumpRenamedAst.hs:32:12 })) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:32:11 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -220,14 +220,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { DumpSemis.hs:9:11-12 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpSemis.hs:9:11 }) - (EpaSpan { DumpSemis.hs:9:12 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpSemis.hs:9:11 }) + (EpaSpan { DumpSemis.hs:9:12 })) (HsBoxedOrConstraintTuple) [])))))))))) ,(L @@ -525,14 +521,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { DumpSemis.hs:14:11-12 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpSemis.hs:14:11 }) - (EpaSpan { DumpSemis.hs:14:12 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpSemis.hs:14:11 }) + (EpaSpan { DumpSemis.hs:14:12 })) (HsBoxedOrConstraintTuple) [])))))))))) ,(L @@ -793,14 +785,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { DumpSemis.hs:21:11-12 }) - (AnnParen - (AnnParens) - (EpaSpan { DumpSemis.hs:21:11 }) - (EpaSpan { DumpSemis.hs:21:12 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { DumpSemis.hs:21:11 }) + (EpaSpan { DumpSemis.hs:21:12 })) (HsBoxedOrConstraintTuple) [])))))))))) ,(L ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -304,14 +304,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { KindSigs.hs:15:14-51 }) - (AnnParen - (AnnParens) - (EpaSpan { KindSigs.hs:15:14 }) - (EpaSpan { KindSigs.hs:15:51 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { KindSigs.hs:15:14 }) + (EpaSpan { KindSigs.hs:15:51 })) (HsBoxedOrConstraintTuple) [(L (EpAnn @@ -548,14 +544,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { KindSigs.hs:16:15-54 }) - (AnnParen - (AnnParensHash) - (EpaSpan { KindSigs.hs:16:15-16 }) - (EpaSpan { KindSigs.hs:16:53-54 })) - (EpaComments - [])) + (AnnParen + (AnnParensHash) + (EpaSpan { KindSigs.hs:16:15-16 }) + (EpaSpan { KindSigs.hs:16:53-54 })) (HsUnboxedTuple) [(L (EpAnn @@ -769,14 +761,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { KindSigs.hs:19:12-26 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { KindSigs.hs:19:12 }) - (EpaSpan { KindSigs.hs:19:26 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { KindSigs.hs:19:12 }) + (EpaSpan { KindSigs.hs:19:26 })) (L (EpAnn (EpaSpan { KindSigs.hs:19:14-24 }) @@ -1028,14 +1016,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { KindSigs.hs:22:34-35 }) - (AnnParen - (AnnParens) - (EpaSpan { KindSigs.hs:22:34 }) - (EpaSpan { KindSigs.hs:22:35 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { KindSigs.hs:22:34 }) + (EpaSpan { KindSigs.hs:22:35 })) (HsBoxedOrConstraintTuple) [])) (L @@ -1580,14 +1564,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { KindSigs.hs:28:34-39 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { KindSigs.hs:28:34 }) - (EpaSpan { KindSigs.hs:28:39 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { KindSigs.hs:28:34 }) + (EpaSpan { KindSigs.hs:28:39 })) (L (EpAnn (EpaSpan { KindSigs.hs:28:35-38 }) ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -432,14 +432,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { T20452.hs:8:57-74 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { T20452.hs:8:57 }) - (EpaSpan { T20452.hs:8:74 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { T20452.hs:8:57 }) + (EpaSpan { T20452.hs:8:74 })) (L (EpAnn (EpaSpan { T20452.hs:8:58-73 }) @@ -448,14 +444,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { T20452.hs:8:58-73 }) - (AnnParen - (AnnParens) - (EpaSpan { T20452.hs:8:58 }) - (EpaSpan { T20452.hs:8:73 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { T20452.hs:8:58 }) + (EpaSpan { T20452.hs:8:73 })) (HsBoxedOrConstraintTuple) [(L (EpAnn @@ -687,14 +679,10 @@ (EpaComments [])) (HsListTy - (EpAnn - (EpaSpan { T20452.hs:9:57-74 }) - (AnnParen - (AnnParensSquare) - (EpaSpan { T20452.hs:9:57 }) - (EpaSpan { T20452.hs:9:74 })) - (EpaComments - [])) + (AnnParen + (AnnParensSquare) + (EpaSpan { T20452.hs:9:57 }) + (EpaSpan { T20452.hs:9:74 })) (L (EpAnn (EpaSpan { T20452.hs:9:58-73 }) @@ -703,14 +691,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { T20452.hs:9:58-73 }) - (AnnParen - (AnnParens) - (EpaSpan { T20452.hs:9:58 }) - (EpaSpan { T20452.hs:9:73 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { T20452.hs:9:58 }) + (EpaSpan { T20452.hs:9:73 })) (HsBoxedOrConstraintTuple) [(L (EpAnn ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -98,14 +98,10 @@ (EpaComments [])) (HsTupleTy - (EpAnn - (EpaSpan { T23315.hsig:3:6-7 }) - (AnnParen - (AnnParens) - (EpaSpan { T23315.hsig:3:6 }) - (EpaSpan { T23315.hsig:3:7 })) - (EpaComments - [])) + (AnnParen + (AnnParens) + (EpaSpan { T23315.hsig:3:6 }) + (EpaSpan { T23315.hsig:3:7 })) (HsBoxedOrConstraintTuple) [])))))))) ,(L ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -912,26 +912,12 @@ data AnnParen ap_close :: EpaLocation } deriving (Data) -} -markOpeningParen, markClosingParen :: (Monad m, Monoid w) => EpAnn AnnParen -> EP w m (EpAnn AnnParen) +markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen markOpeningParen an = markParen an lfst markClosingParen an = markParen an lsnd -markParen :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. Lens (a,a) a) -> EP w m (EpAnn AnnParen) -markParen (EpAnn anc (AnnParen pt o c) cs) l = do - loc' <- markKwA (view l $ kw pt) (view l (o, c)) - let (o',c') = set l loc' (o,c) - return (EpAnn anc (AnnParen pt o' c') cs) - where - kw AnnParens = (AnnOpenP, AnnCloseP) - kw AnnParensHash = (AnnOpenPH, AnnClosePH) - kw AnnParensSquare = (AnnOpenS, AnnCloseS) - -markOpeningParen', markClosingParen' :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen -markOpeningParen' an = markParen' an lfst -markClosingParen' an = markParen' an lsnd - -markParen' :: (Monad m, Monoid w) => AnnParen -> (forall a. Lens (a,a) a) -> EP w m AnnParen -markParen' (AnnParen pt o c) l = do +markParen :: (Monad m, Monoid w) => AnnParen -> (forall a. Lens (a,a) a) -> EP w m AnnParen +markParen (AnnParen pt o c) l = do loc' <- markKwA (view l $ kw pt) (view l (o, c)) let (o',c') = set l loc' (o,c) return (AnnParen pt o' c') @@ -4044,18 +4030,18 @@ instance ExactPrint (HsType GhcPs) where getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal getAnnotationEntry (HsFunTy _ _ _ _) = NoEntryVal - getAnnotationEntry (HsListTy an _) = fromAnn an - getAnnotationEntry (HsTupleTy an _ _) = fromAnn an - getAnnotationEntry (HsSumTy an _) = fromAnn an - getAnnotationEntry (HsOpTy an _ _ _ _) = fromAnn an + getAnnotationEntry (HsListTy _ _) = NoEntryVal + getAnnotationEntry (HsTupleTy _ _ _) = NoEntryVal + getAnnotationEntry (HsSumTy _ _) = NoEntryVal + getAnnotationEntry (HsOpTy _ _ _ _ _) = NoEntryVal getAnnotationEntry (HsParTy _ _) = NoEntryVal - getAnnotationEntry (HsIParamTy an _ _) = fromAnn an + getAnnotationEntry (HsIParamTy _ _ _) = NoEntryVal getAnnotationEntry (HsStarTy _ _) = NoEntryVal getAnnotationEntry (HsKindSig an _ _) = fromAnn an getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal getAnnotationEntry (HsDocTy _ _ _) = NoEntryVal getAnnotationEntry (HsBangTy _ _ _) = NoEntryVal - getAnnotationEntry (HsRecTy an _) = fromAnn an + getAnnotationEntry (HsRecTy _ _) = NoEntryVal getAnnotationEntry (HsExplicitListTy _ _ _) = NoEntryVal getAnnotationEntry (HsExplicitTupleTy _ _) = NoEntryVal getAnnotationEntry (HsTyLit _ _) = NoEntryVal @@ -4068,18 +4054,18 @@ instance ExactPrint (HsType GhcPs) where setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _ _s = a setAnnotationAnchor a@(HsFunTy{}) _ _ _s = a - setAnnotationAnchor (HsListTy an a) anc ts cs = (HsListTy (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (HsTupleTy an a b) anc ts cs = (HsTupleTy (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsSumTy an a) anc ts cs = (HsSumTy (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _ _s = a + setAnnotationAnchor a@(HsListTy{}) _ _ _s = a + setAnnotationAnchor a@(HsTupleTy{}) _ _ _s = a + setAnnotationAnchor a@(HsSumTy{}) _ _ _s = a + setAnnotationAnchor a@(HsOpTy{}) _ _ _s = a setAnnotationAnchor a@(HsParTy{}) _ _ _s = a - setAnnotationAnchor (HsIParamTy an a b) anc ts cs = (HsIParamTy (setAnchorEpa an anc ts cs) a b) + setAnnotationAnchor a@(HsIParamTy{}) _ _ _s = a setAnnotationAnchor a@(HsStarTy _ _) _ _ _s = a setAnnotationAnchor (HsKindSig an a b) anc ts cs = (HsKindSig (setAnchorEpa an anc ts cs) a b) setAnnotationAnchor a@(HsSpliceTy _ _) _ _ _s = a setAnnotationAnchor a@(HsDocTy{}) _ _ _s = a setAnnotationAnchor a@(HsBangTy{}) _ _ _s = a - setAnnotationAnchor (HsRecTy an a) anc ts cs = (HsRecTy (setAnchorEpa an anc ts cs) a) + setAnnotationAnchor a@(HsRecTy{}) _ _ _s = a setAnnotationAnchor a@(HsExplicitListTy{}) _ _ _s = a setAnnotationAnchor a@(HsExplicitTupleTy{}) _ _ _s = a setAnnotationAnchor a@(HsTyLit _ _) _ _ _s = a @@ -4134,20 +4120,20 @@ instance ExactPrint (HsType GhcPs) where return (HsSumTy an1 tys') exact (HsOpTy an promoted t1 lo t2) = do an0 <- if (isPromoted promoted) - then markEpAnnL an lidl AnnSimpleQuote + then markEpAnnL' an lidl AnnSimpleQuote else return an t1' <- markAnnotated t1 lo' <- markAnnotated lo t2' <- markAnnotated t2 return (HsOpTy an0 promoted t1' lo' t2') exact (HsParTy an ty) = do - an0 <- markOpeningParen' an + an0 <- markOpeningParen an ty' <- markAnnotated ty - an1 <- markClosingParen' an0 + an1 <- markClosingParen an0 return (HsParTy an1 ty') exact (HsIParamTy an n t) = do n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon t' <- markAnnotated t return (HsIParamTy an0 n' t') exact (HsStarTy an isUnicode) = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86960e06a48eaf6ac011cf40c4623e2e65aeaef0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86960e06a48eaf6ac011cf40c4623e2e65aeaef0 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 Dec 10 18:39:23 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Sun, 10 Dec 2023 13:39:23 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: use EpToken for dcol in ConDeclGADT Message-ID: <657605db5a6d9_3478bc57346a144262db@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: f175c9ea by Vladislav Zavialov at 2023-12-10T21:35:26+03:00 EPA: use EpToken for dcol in ConDeclGADT - - - - - 17 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Concrete.hs - compiler/Language/Haskell/Syntax/Decls.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/printer/T18791.stderr - utils/check-exact/ExactPrint.hs - utils/haddock Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -665,8 +665,13 @@ type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn] -type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn] +type instance XConDeclGADT GhcPs = (EpUniToken "::" "∷", EpAnn [AddEpAnn]) +type instance XConDeclGADT GhcRn = NoExtField +type instance XConDeclGADT GhcTc = NoExtField + +type instance XConDeclH98 GhcPs = EpAnn [AddEpAnn] +type instance XConDeclH98 GhcRn = NoExtField +type instance XConDeclH98 GhcTc = NoExtField type instance XXConDecl (GhcPass _) = DataConCantHappen ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -242,11 +242,6 @@ type instance Anno (HsToken tok) = TokenLocation noHsTok :: GenLocated TokenLocation (HsToken tok) noHsTok = L NoTokenLoc HsTok -type instance Anno (HsUniToken tok utok) = TokenLocation - -noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) -noHsUniTok = L NoTokenLoc HsNormalTok - --- Outputable instance Outputable NoExtField where @@ -256,8 +251,4 @@ instance Outputable DataConCantHappen where ppr = dataConCantHappen instance KnownSymbol tok => Outputable (HsToken tok) where - ppr _ = text (symbolVal (Proxy :: Proxy tok)) - -instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where - ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) - ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) \ No newline at end of file + ppr _ = text (symbolVal (Proxy :: Proxy tok)) \ No newline at end of file ===================================== compiler/GHC/Parser.y ===================================== @@ -2434,7 +2434,7 @@ gadt_constr :: { LConDecl GhcPs } -- Returns a list because of: C,D :: ty -- TODO:AZ capture the optSemi. Why leading? : optSemi con_list '::' sigtype - {% mkGadtDecl (comb2 $2 $>) (unLoc $2) (hsUniTok $3) $4 } + {% mkGadtDecl (comb2 $2 $>) (unLoc $2) (epUniTok $3) $4 } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4494,11 +4494,6 @@ epUniTok t@(L l _) = EpUniTok (EpaSpan l) u hsTok' :: Located Token -> Located (HsToken tok) hsTok' (L l _) = L l HsTok -hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs -hsUniTok t@(L l _) = - L (mkTokenLocation l) - (if isUnicode t then HsUnicodeTok else HsNormalTok) - epExplicitBraces :: Located Token -> Located Token -> EpLayout epExplicitBraces t1 t2 = EpExplicitBraces (epTok t1) (epTok t2) ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -806,7 +806,7 @@ mkConDeclH98 ann name mb_forall mb_cxt args -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. mkGadtDecl :: SrcSpan -> NonEmpty (LocatedN RdrName) - -> LHsUniToken "::" "∷" GhcPs + -> EpUniToken "::" "∷" -> LHsSigType GhcPs -> P (LConDecl GhcPs) mkGadtDecl loc names dcol ty = do @@ -835,9 +835,8 @@ mkGadtDecl loc names dcol ty = do HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments pure $ L l ConDeclGADT - { con_g_ext = an + { con_g_ext = (dcol, an) , con_names = names - , con_dcolon = dcol , con_bndrs = L bndrs_loc outer_bndrs , con_mb_cxt = mcxt , con_g_args = args ===================================== compiler/GHC/Parser/PostProcess/Haddock.hs ===================================== @@ -698,7 +698,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where addHaddock (L l_con_decl con_decl) = extendHdkA (locA l_con_decl) $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do + ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names)) con_g_args' <- @@ -710,7 +710,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where pure $ RecConGADT arr (L l_rec flds') con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ - ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, + ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2400,7 +2400,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) ; mb_doc' <- traverse rnLHsDoc mb_doc - ; return (decl { con_ext = noAnn + ; return (decl { con_ext = noExtField , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc' @@ -2408,7 +2408,6 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs all_fvs) }} rnConDecl (ConDeclGADT { con_names = names - , con_dcolon = dcol , con_bndrs = L l outer_bndrs , con_mb_cxt = mcxt , con_g_args = args @@ -2446,8 +2445,7 @@ rnConDecl (ConDeclGADT { con_names = names ; traceRn "rnConDecl (ConDeclGADT)" (ppr names $$ ppr outer_bndrs') ; new_mb_doc <- traverse rnLHsDoc mb_doc - ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names - , con_dcolon = dcol + ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt , con_g_args = new_args, con_res_ty = new_res_ty , con_doc = new_mb_doc }, ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -747,7 +747,6 @@ mk_gadt_decl names args res_ty returnLA $ ConDeclGADT { con_g_ext = noAnn , con_names = names - , con_dcolon = noHsUniTok , con_bndrs = bndrs , con_mb_cxt = Nothing , con_g_args = args ===================================== compiler/Language/Haskell/Syntax/Concrete.hs ===================================== @@ -6,9 +6,7 @@ -- | Bits of concrete syntax (tokens, layout). module Language.Haskell.Syntax.Concrete - ( LHsToken, LHsUniToken, - HsToken(HsTok), - HsUniToken(HsNormalTok, HsUnicodeTok), + ( LHsToken, HsToken(HsTok), ) where import GHC.Prelude @@ -17,7 +15,6 @@ import Data.Data import Language.Haskell.Syntax.Extension type LHsToken tok p = XRec p (HsToken tok) -type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) -- | A token stored in the syntax tree. For example, when parsing a -- let-expression, we store @HsToken "let"@ and @HsToken "in"@. @@ -25,15 +22,5 @@ type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) -- (exactprint) the original program text. data HsToken (tok :: Symbol) = HsTok --- | With @UnicodeSyntax@, there might be multiple ways to write the same --- token. For example an arrow could be either @->@ or @→@. This choice must be --- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we --- introduce @HsUniToken "->" "→"@. --- --- See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to --- avoid a dependency. -data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok - deriving instance Eq (HsToken tok) -deriving instance KnownSymbol tok => Data (HsToken tok) -deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) \ No newline at end of file +deriving instance KnownSymbol tok => Data (HsToken tok) \ No newline at end of file ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -95,7 +95,6 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role) @@ -1080,7 +1079,6 @@ data ConDecl pass = ConDeclGADT { con_g_ext :: XConDeclGADT pass , con_names :: NonEmpty (LIdP pass) - , con_dcolon :: !(LHsUniToken "::" "∷" pass) -- The following fields describe the type after the '::' -- See Note [GADT abstract syntax] , con_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -1108,11 +1108,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:25:5-18 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:25:10-11 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:25:5-18 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -1124,10 +1128,6 @@ (Unqual {OccName: MkD5})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:25:10-11 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:25:13-18 }) @@ -1485,11 +1485,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:31:5-18 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:31:10-11 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:31:5-18 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -1501,10 +1505,6 @@ (Unqual {OccName: MkD6})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:31:10-11 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:31:13-18 }) @@ -1862,11 +1862,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:37:5-18 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:37:10-11 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:37:5-18 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -1878,10 +1882,6 @@ (Unqual {OccName: MkD7})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:37:10-11 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:37:13-18 }) @@ -2239,11 +2239,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:43:5-18 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:43:10-11 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:43:5-18 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -2255,10 +2259,6 @@ (Unqual {OccName: MkD8})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:43:10-11 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:43:13-18 }) @@ -2616,11 +2616,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:49:5-18 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:49:10-11 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:49:5-18 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -2632,10 +2636,6 @@ (Unqual {OccName: MkD9})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:49:10-11 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:49:13-18 }) @@ -2993,11 +2993,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544.hs:55:5-20 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544.hs:55:11-12 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544.hs:55:5-20 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -3009,10 +3013,6 @@ (Unqual {OccName: MkD10})) []) - (L - (TokenLoc - (EpaSpan { T17544.hs:55:11-12 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544.hs:55:14-20 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -89,11 +89,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544_kw.hs:16:9-20 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544_kw.hs:16:15-16 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544_kw.hs:16:9-20 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -105,10 +109,6 @@ (Unqual {OccName: MkFoo})) []) - (L - (TokenLoc - (EpaSpan { T17544_kw.hs:16:15-16 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544_kw.hs:16:18-20 }) @@ -202,11 +202,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T17544_kw.hs:19:9-26 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T17544_kw.hs:19:15-16 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T17544_kw.hs:19:9-26 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -218,10 +222,6 @@ (Unqual {OccName: MkBar})) []) - (L - (TokenLoc - (EpaSpan { T17544_kw.hs:19:15-16 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T17544_kw.hs:19:18-26 }) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -1903,11 +1903,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:3-45 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { DumpParsedAst.hs:23:7-8 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { DumpParsedAst.hs:23:3-45 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -1919,10 +1923,6 @@ (Unqual {OccName: Nat})) []) - (L - (TokenLoc - (EpaSpan { DumpParsedAst.hs:23:7-8 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { DumpParsedAst.hs:23:10-45 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -168,11 +168,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:9:14-17 }) @@ -196,11 +192,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:9:21-24 }) @@ -1094,11 +1086,7 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (:| (L (EpAnn @@ -1109,10 +1097,6 @@ [])) {Name: DumpRenamedAst.Nat}) []) - (L - (TokenLoc - (EpaSpan { DumpRenamedAst.hs:20:7-8 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:20:10-45 }) @@ -1494,11 +1478,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:22:21-23 }) ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -100,11 +100,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T15323.hs:6:5-54 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T15323.hs:6:17-18 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T15323.hs:6:5-54 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -116,10 +120,6 @@ (Unqual {OccName: TestParens})) []) - (L - (TokenLoc - (EpaSpan { T15323.hs:6:17-18 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T15323.hs:6:20-29 }) ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -77,11 +77,15 @@ (EpaComments [])) (ConDeclGADT - (EpAnn - (EpaSpan { T18791.hs:5:3-17 }) - [] - (EpaComments - [])) + ((,) + (EpUniTok + (EpaSpan { T18791.hs:5:7-8 }) + (NormalSyntax)) + (EpAnn + (EpaSpan { T18791.hs:5:3-17 }) + [] + (EpaComments + []))) (:| (L (EpAnn @@ -93,10 +97,6 @@ (Unqual {OccName: MkT})) []) - (L - (TokenLoc - (EpaSpan { T18791.hs:5:7-8 })) - (HsNormalTok)) (L (EpAnn (EpaSpan { T18791.hs:5:10-17 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -852,15 +852,6 @@ markToken (L (TokenLoc aa) t) = do aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) return (L (TokenLoc aa') t) -markUniToken :: forall m w tok utok. (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) - => LHsUniToken tok utok GhcPs -> EP w m (LHsUniToken tok utok GhcPs) -markUniToken (L l HsNormalTok) = do - (L l' _) <- markToken (L l (HsTok @tok)) - return (L l' HsNormalTok) -markUniToken (L l HsUnicodeTok) = do - (L l' _) <- markToken (L l (HsTok @utok)) - return (L l' HsUnicodeTok) - -- --------------------------------------------------------------------- markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) @@ -4422,10 +4413,10 @@ exact_condecls an cs -- --------------------------------------------------------------------- instance ExactPrint (ConDecl GhcPs) where - getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) + getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (snd (con_g_ext x)) getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) - setAnnotationAnchor x at ConDeclGADT{} anc ts cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc ts cs} + setAnnotationAnchor x at ConDeclGADT{} anc ts cs = x { con_g_ext = fmap (\an -> setAnchorEpa an anc ts cs) (con_g_ext x) } setAnnotationAnchor x at ConDeclH98{} anc ts cs = x { con_ext = setAnchorEpa (con_ext x) anc ts cs} -- based on pprConDecl @@ -4477,14 +4468,13 @@ instance ExactPrint (ConDecl GhcPs) where -- ----------------------------------- - exact (ConDeclGADT { con_g_ext = an + exact (ConDeclGADT { con_g_ext = (dcol, an) , con_names = cons - , con_dcolon = dcol , con_bndrs = bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = do cons' <- mapM markAnnotated cons - dcol' <- markUniToken dcol + dcol' <- markEpUniToken dcol an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 @@ -4506,9 +4496,8 @@ instance ExactPrint (ConDecl GhcPs) where rarr' <- markEpUniToken rarr return (RecConGADT rarr' fields') res_ty' <- markAnnotated res_ty - return (ConDeclGADT { con_g_ext = an2 + return (ConDeclGADT { con_g_ext = (dcol', an2) , con_names = cons' - , con_dcolon = dcol' , con_bndrs = bndrs' , con_mb_cxt = mcxt', con_g_args = args' , con_res_ty = res_ty', con_doc = doc }) ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit bbc5ab1bc4c2d064e3dd5f7413f527d57b53a6b1 +Subproject commit 5b607d9ae5770d68df48c6334ac3ef22404f6a65 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f175c9eafa4cd82325f87c70b69207d49259dd7f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f175c9eafa4cd82325f87c70b69207d49259dd7f 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 Dec 10 19:12:59 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Sun, 10 Dec 2023 14:12:59 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove the last LHs(Uni)Token Message-ID: <65760dbb69821_3478bc57d2aabc427649@gitlab.mail> Vladislav Zavialov pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: ba522d6e by Vladislav Zavialov at 2023-12-10T21:47:54+03:00 EPA: Remove the last LHs(Uni)Token - - - - - 10 changed files: - compiler/GHC/Hs/Extension.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/Language/Haskell/Syntax.hs - − compiler/Language/Haskell/Syntax/Concrete.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -25,10 +25,7 @@ module GHC.Hs.Extension where import GHC.Prelude -import GHC.TypeLits (KnownSymbol, symbolVal) - import Data.Data hiding ( Fixity ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader @@ -237,18 +234,10 @@ pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc pp = case ghcPass @p of GhcTc -> pp _ -> empty -type instance Anno (HsToken tok) = TokenLocation - -noHsTok :: GenLocated TokenLocation (HsToken tok) -noHsTok = L NoTokenLoc HsTok - --- Outputable instance Outputable NoExtField where ppr _ = text "NoExtField" instance Outputable DataConCantHappen where - ppr = dataConCantHappen - -instance KnownSymbol tok => Outputable (HsToken tok) where - ppr _ = text (symbolVal (Proxy :: Proxy tok)) \ No newline at end of file + ppr = dataConCantHappen \ No newline at end of file ===================================== compiler/GHC/Parser.y ===================================== @@ -1979,7 +1979,7 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } | {- empty -} { Nothing } warning_category :: { Maybe (Located InWarningCategory) } - : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (hsTok' $1) (getSTRINGs $2) + : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2) (sL1 $2 $ mkWarningCategory (getSTRING $2))) } | {- empty -} { Nothing } @@ -4491,9 +4491,6 @@ epUniTok t@(L l _) = EpUniTok (EpaSpan l) u where u = if isUnicode t then UnicodeSyntax else NormalSyntax -hsTok' :: Located Token -> Located (HsToken tok) -hsTok' (L l _) = L l HsTok - epExplicitBraces :: Located Token -> Located Token -> EpLayout epExplicitBraces t1 t2 = EpExplicitBraces (epTok t1) (epTok t2) ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -111,7 +111,6 @@ import GHC.Hs.DocString import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict -import Language.Haskell.Syntax.Concrete (HsToken(..)) {- Note [exact print annotations] @@ -1400,9 +1399,6 @@ instance NoAnn AnnPragma where instance NoAnn AnnParen where noAnn = AnnParen AnnParens noAnn noAnn -instance NoAnn (GenLocated TokenLocation (HsToken s)) where - noAnn = L NoTokenLoc HsTok - instance NoAnn (EpToken s) where noAnn = NoEpTok ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -63,7 +63,6 @@ import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Unicode -import Language.Haskell.Syntax.Concrete (HsToken (HsTok)) import Language.Haskell.Syntax.Extension import Data.Data @@ -120,13 +119,13 @@ the possibility of them being infinite. data InWarningCategory = InWarningCategory - { iwc_in :: !(Located (HsToken "in")), + { iwc_in :: !(EpToken "in"), iwc_st :: !SourceText, iwc_wc :: (Located WarningCategory) } deriving Data fromWarningCategory :: WarningCategory -> InWarningCategory -fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc) +fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLoc wc) -- See Note [Warning categories] @@ -238,7 +237,7 @@ warningTxtSame w1 w2 deriving instance Eq InWarningCategory -deriving instance (Eq (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass) +deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP ===================================== compiler/Language/Haskell/Syntax.hs ===================================== @@ -25,7 +25,6 @@ module Language.Haskell.Syntax ( module Language.Haskell.Syntax.Module.Name, module Language.Haskell.Syntax.Pat, module Language.Haskell.Syntax.Type, - module Language.Haskell.Syntax.Concrete, module Language.Haskell.Syntax.Extension, ModuleName(..), HsModule(..) ) where @@ -36,7 +35,6 @@ import Language.Haskell.Syntax.Expr import Language.Haskell.Syntax.ImpExp import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type ===================================== compiler/Language/Haskell/Syntax/Concrete.hs deleted ===================================== @@ -1,26 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | Bits of concrete syntax (tokens, layout). - -module Language.Haskell.Syntax.Concrete - ( LHsToken, HsToken(HsTok), - ) where - -import GHC.Prelude -import GHC.TypeLits (Symbol, KnownSymbol) -import Data.Data -import Language.Haskell.Syntax.Extension - -type LHsToken tok p = XRec p (HsToken tok) - --- | A token stored in the syntax tree. For example, when parsing a --- let-expression, we store @HsToken "let"@ and @HsToken "in"@. --- The locations of those tokens can be used to faithfully reproduce --- (exactprint) the original program text. -data HsToken (tok :: Symbol) = HsTok - -deriving instance Eq (HsToken tok) -deriving instance KnownSymbol tok => Data (HsToken tok) \ No newline at end of file ===================================== compiler/ghc.cabal.in ===================================== @@ -940,7 +940,6 @@ Library Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds - Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension ===================================== testsuite/tests/count-deps/CountDepsAst.stdout ===================================== @@ -223,7 +223,6 @@ GHC.Utils.Word64 Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds -Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -243,7 +243,6 @@ GHC.Utils.Word64 Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds -Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -820,15 +820,6 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do -- --------------------------------------------------------------------- -markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) - => Located (HsToken tok) -> EP w m (Located (HsToken tok)) -markLToken (L (RealSrcSpan aa mb) t) = do - epaLoc'<- printStringAtAA (EpaSpan (RealSrcSpan aa mb)) (symbolVal (Proxy @tok)) - case epaLoc' of - EpaSpan (RealSrcSpan aa' mb') -> return (L (RealSrcSpan aa' mb') t) - _ -> return (L (RealSrcSpan aa mb ) t) -markLToken (L lt t) = return (L lt t) - markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => EpToken tok -> EP w m (EpToken tok) markEpToken NoEpTok = return NoEpTok @@ -845,13 +836,6 @@ markEpUniToken (EpUniTok aa isUnicode) = do UnicodeSyntax -> printStringAtAA aa (symbolVal (Proxy @utok)) return (EpUniTok aa' isUnicode) -markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) - => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) -markToken (L NoTokenLoc t) = return (L NoTokenLoc t) -markToken (L (TokenLoc aa) t) = do - aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) - return (L (TokenLoc aa') t) - -- --------------------------------------------------------------------- markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) @@ -1710,7 +1694,7 @@ instance ExactPrint InWarningCategory where setAnnotationAnchor a _ _ _ = a exact (InWarningCategory tkIn source (L l wc)) = do - tkIn' <- markLToken tkIn + tkIn' <- markEpToken tkIn L _ (_,wc') <- markAnnotated (L l (source, wc)) return (InWarningCategory tkIn' source (L l wc')) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba522d6e71d1425fac178c0dbf6f6ee8d728ecb9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba522d6e71d1425fac178c0dbf6f6ee8d728ecb9 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 Dec 10 21:11:55 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sun, 10 Dec 2023 16:11:55 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove EpAnn from last extension points HsType Message-ID: <6576299b7fb32_3478bc5ad350b84382d0@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: e848e044 by Alan Zimmerman at 2023-12-10T21:10:46+00:00 EPA: Remove EpAnn from last extension points HsType Also replace `EpAnn NoEpAnns` with `EpAnnCO` - - - - - 24 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/printer/T18791.stderr - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -876,7 +876,7 @@ type instance Anno [LocatedN Id] = SrcSpan type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = EpAnn NoEpAnns +type instance Anno StringLiteral = EpAnnCO type instance Anno (LocatedN RdrName) = SrcSpan type instance Anno (LocatedN Name) = SrcSpan type instance Anno (LocatedN Id) = SrcSpan ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1222,8 +1222,8 @@ instance NoAnn HsRuleAnn where flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn] -type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn] +type instance XCRuleBndr (GhcPass _) = [AddEpAnn] +type instance XRuleBndrSig (GhcPass _) = [AddEpAnn] type instance XXRuleBndr (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where @@ -1341,7 +1341,7 @@ type instance XCRoleAnnotDecl GhcTc = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = EpAnn NoEpAnns +type instance Anno (Maybe Role) = EpAnnCO instance OutputableBndr (IdP (GhcPass p)) => Outputable (RoleAnnotDecl (GhcPass p)) where @@ -1367,15 +1367,15 @@ type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA -type instance Anno (FamilyResultSig (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (InjectivityAnn (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO type instance Anno CType = SrcSpanAnnP -type instance Anno (HsDerivingClause (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno Bool = EpAnn NoEpAnns +type instance Anno Bool = EpAnnCO type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA @@ -1386,18 +1386,18 @@ type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP -type instance Anno (DerivStrategy (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (SourceText, RuleName) = EpAnn NoEpAnns -type instance Anno (RuleBndr (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (SourceText, RuleName) = EpAnnCO +type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (Maybe Role) = EpAnn NoEpAnns +type instance Anno (Maybe Role) = EpAnnCO type instance Anno CCallConv = SrcSpan type instance Anno Safety = SrcSpan type instance Anno CExportSpec = SrcSpan ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -57,6 +57,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 showAstData' = generic `ext1Q` list + `extQ` list_addEpAnn `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan `extQ` annotation `extQ` annotationModule @@ -101,26 +102,20 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 bytestring :: B.ByteString -> SDoc bytestring = text . normalize_newlines . show + list_addEpAnn :: [AddEpAnn] -> SDoc + list_addEpAnn ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[AddEpAnn]" + NoBlankEpAnnotations -> list ls + list [] = brackets empty - list [x] = hideOr x (brackets (showAstData' x)) - list (x1 : x2 : xs) = hideOr x1 - ((text "[" <> showAstData' x1) - $$ go x2 xs) + list [x] = brackets (showAstData' x) + list (x1 : x2 : xs) = (text "[" <> showAstData' x1) + $$ go x2 xs where go y [] = text "," <> showAstData' y <> text "]" go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys - hideOr :: forall a .(Data a, Typeable a) => a -> SDoc -> SDoc - hideOr x f = if hide x - then text "blanked:[AddEpAnn]" - else f - - hide :: forall a .(Data a, Typeable a) => a -> Bool - hide x = ba == BlankEpAnnotations && isAddEpAnn x - - isAddEpAnn :: forall a .(Data a, Typeable a) => a -> Bool - isAddEpAnn x = (showConstr (toConstr x)) == "AddEpAnn" - -- Eliminate word-size dependence lit :: HsLit GhcPs -> SDoc lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -2199,26 +2199,26 @@ type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL -type instance Anno (HsCmdTop (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA -type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnn NoEpAnns -type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = EpAnn NoEpAnns +type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO +type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = EpAnnCO type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL -type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO type instance Anno FieldLabelString = SrcSpanAnnN -type instance Anno FastString = EpAnn NoEpAnns +type instance Anno FastString = EpAnnCO -- Used in HsQuasiQuote and perhaps elsewhere -type instance Anno (DotFieldOcc (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (DotFieldOcc (GhcPass p)) = EpAnnCO instance (HasAnnotation (Anno a)) => WrapXRec (GhcPass p) a where ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -862,7 +862,7 @@ collectEvVarsPat pat = -} type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA -type instance Anno (HsOverLit (GhcPass p)) = EpAnn NoEpAnns +type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA type instance Anno RecFieldsDotDot = SrcSpan ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -305,8 +305,8 @@ mkEmptyWildCardBndrs x = HsWC { hswc_body = x -------------------------------------------------- -type instance XUserTyVar (GhcPass _) = EpAnn [AddEpAnn] -type instance XKindedTyVar (GhcPass _) = EpAnn [AddEpAnn] +type instance XUserTyVar (GhcPass _) = [AddEpAnn] +type instance XKindedTyVar (GhcPass _) = [AddEpAnn] type instance XXTyVarBndr (GhcPass _) = DataConCantHappen @@ -349,7 +349,7 @@ type instance XXBndrVis (GhcPass _) = DataConCantHappen type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] +type instance XTyVar (GhcPass _) = [AddEpAnn] type instance XAppTy (GhcPass _) = NoExtField type instance XFunTy (GhcPass _) = NoExtField type instance XListTy (GhcPass _) = AnnParen @@ -359,7 +359,7 @@ type instance XOpTy (GhcPass _) = [AddEpAnn] type instance XParTy (GhcPass _) = AnnParen type instance XIParamTy (GhcPass _) = [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] +type instance XKindSig (GhcPass _) = [AddEpAnn] type instance XAppKindTy GhcPs = EpToken "@" type instance XAppKindTy GhcRn = NoExtField @@ -1480,7 +1480,7 @@ type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA -type instance Anno HsIPName = EpAnn NoEpAnns +type instance Anno HsIPName = EpAnnCO type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Parser.y ===================================== @@ -1941,7 +1941,7 @@ rule_vars :: { [LRuleTyTmVar] } rule_var :: { LRuleTyTmVar } : varid { sL1a $1 (RuleTyTmVar noAnn $1 Nothing) } - | '(' varid '::' ctype ')' {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glEE $1 $>) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) } + | '(' varid '::' ctype ')' {% amsA' (sLL $1 $> (RuleTyTmVar [mop $1,mu AnnDcolon $3,mcp $5] $2 (Just $4))) } {- Note [Parsing explicit foralls in Rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2120,8 +2120,8 @@ opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) } -- See Note [forall-or-nothing rule] in GHC.Hs.Type. sigktype :: { LHsSigType GhcPs } : sigtype { $1 } - | ctype '::' kind {% acsA (\cs -> sLL $1 $> $ mkHsImplicitSigType $ - sLLa $1 $> $ HsKindSig (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) $1 $3) } + | ctype '::' kind {% amsA' (sLL $1 $> $ mkHsImplicitSigType $ + sLLa $1 $> $ HsKindSig [mu AnnDcolon $2] $1 $3) } -- Like ctype, but for types that obey the forall-or-nothing rule. -- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the @@ -2161,7 +2161,7 @@ forall_telescope :: { Located (HsForAllTelescope GhcPs) } -- A ktype is a ctype, possibly with a kind annotation ktype :: { LHsType GhcPs } : ctype { $1 } - | ctype '::' kind {% acsA (\cs -> sLL $1 $> $ HsKindSig (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) $1 $3) } + | ctype '::' kind {% amsA' (sLL $1 $> $ HsKindSig [mu AnnDcolon $2] $1 $3) } -- A ctype is a for-all type ctype :: { LHsType GhcPs } @@ -2257,9 +2257,9 @@ tyop :: { (LocatedN RdrName, PromotionFlag) } ; return (op, IsPromoted) } } atype :: { LHsType GhcPs } - : ntgtycon {% acsA (\cs -> sL1 $1 (HsTyVar (EpAnn (glR $1) [] cs) NotPromoted $1)) } -- Not including unit tuples + : ntgtycon {% amsA' (sL1 $1 (HsTyVar [] NotPromoted $1)) } -- Not including unit tuples -- See Note [%shift: atype -> tyvar] - | tyvar %shift {% acsA (\cs -> sL1 $1 (HsTyVar (EpAnn (glR $1) [] cs) NotPromoted $1)) } -- (See Note [Unit tuples]) + | tyvar %shift {% amsA' (sL1 $1 (HsTyVar [] NotPromoted $1)) } -- (See Note [Unit tuples]) | '*' {% do { warnStarIsType (getLoc $1) ; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } } @@ -2283,12 +2283,12 @@ atype :: { LHsType GhcPs } | quasiquote { mapLocA (HsSpliceTy noExtField) $1 } | splice_untyped { mapLocA (HsSpliceTy noExtField) $1 } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } + | SIMPLEQUOTE qcon_nowiredlist {% amsA' (sLL $1 $> $ HsTyVar [mj AnnSimpleQuote $1,mjN AnnName $2] IsPromoted $2) } | SIMPLEQUOTE '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $3 (gl $4) ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $6] (h : $5)) }} | SIMPLEQUOTE '[' comma_types0 ']' {% amsA' (sLL $1 $> $ HsExplicitListTy [mj AnnSimpleQuote $1,mos $2,mcs $4] IsPromoted $3) } - | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 $> $ HsTyVar (EpAnn (glEE $1 $>) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } + | SIMPLEQUOTE var {% amsA' (sLL $1 $> $ HsTyVar [mj AnnSimpleQuote $1,mjN AnnName $2] IsPromoted $2) } -- Two or more [ty, ty, ty] must be a promoted list type, just as -- if you had written '[ty, ty, ty] @@ -2306,7 +2306,7 @@ atype :: { LHsType GhcPs } -- Type variables are never exported, so `M.tyvar` will be rejected by the renamer. -- We let it pass the parser because the renamer can generate a better error message. | QVARID {% let qname = mkQual tvName (getQVARID $1) - in acsA (\cs -> sL1 $1 (HsTyVar (EpAnn (glEE $1 $>) [] cs) NotPromoted (sL1n $1 $ qname)))} + in amsA' (sL1 $1 (HsTyVar [] NotPromoted (sL1n $1 $ qname)))} -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -2341,12 +2341,12 @@ tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] } tv_bndr :: { LHsTyVarBndr Specificity GhcPs } : tv_bndr_no_braces { $1 } - | '{' tyvar '}' {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glEE $1 $>) [moc $1, mcc $3] cs) InferredSpec $2)) } - | '{' tyvar '::' kind '}' {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glEE $1 $>) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) } + | '{' tyvar '}' {% amsA' (sLL $1 $> (UserTyVar [moc $1, mcc $3] InferredSpec $2)) } + | '{' tyvar '::' kind '}' {% amsA' (sLL $1 $> (KindedTyVar [moc $1,mu AnnDcolon $3 ,mcc $5] InferredSpec $2 $4)) } tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs } - : tyvar {% acsA (\cs -> (sL1 $1 (UserTyVar (EpAnn (glR $1) [] cs) SpecifiedSpec $1))) } - | '(' tyvar '::' kind ')' {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glEE $1 $>) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) } + : tyvar {% amsA' (sL1 $1 (UserTyVar [] SpecifiedSpec $1)) } + | '(' tyvar '::' kind ')' {% amsA' (sLL $1 $> (KindedTyVar [mop $1,mu AnnDcolon $3 ,mcp $5] SpecifiedSpec $2 $4)) } fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) } : {- empty -} { noLoc ([],[]) } @@ -2998,7 +2998,7 @@ aexp2 :: { ECP } | '_' { ECP $ pvA $ mkHsWildCardPV (getLoc $1) } -- Template Haskell Extension - | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 } + | splice_untyped { ECP $ pvA' $ mkHsSplicePV $1 } | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) } | SIMPLEQUOTE qvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) } @@ -3021,7 +3021,7 @@ aexp2 :: { ECP } amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (PatBr noExtField p)) } | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket (mo $1:mu AnnCloseQ $3:fst $2) (DecBrL noExtField (snd $2))) } - | quasiquote { ECP $ pvA $ mkHsSplicePV $1 } + | quasiquote { ECP $ pvA' $ mkHsSplicePV $1 } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -944,39 +944,37 @@ checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM check tparms ; return (mkHsQTvs tvs) } where - check (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki - check (HsValArg _ ty) = chkParens [] [] emptyComments (HsBndrRequired noExtField) ty + check (HsTypeArg at ki) = chkParens [] [] (HsBndrInvisible at) ki + check (HsValArg _ ty) = chkParens [] [] (HsBndrRequired noExtField) ty check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ (PsErrMalformedDecl pp_what (unLoc tc)) -- Keep around an action for adjusting the annotations of extra parens - chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs + chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) - chkParens ops cps cs bvis (L l (HsParTy _ ty)) + chkParens ops cps bvis (L l (HsParTy _ ty)) = let (o,c) = mkParensEpAnn (realSrcSpan $ locA l) in - chkParens (o:ops) (c:cps) cs bvis ty - chkParens ops cps cs bvis ty = chk ops cps cs bvis ty + chkParens (o:ops) (c:cps) bvis ty + chkParens ops cps bvis ty = chk ops cps bvis ty -- Check that the name space is correct! - chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) - chk ops cps cs bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) + chk :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) + chk ops cps bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) | isRdrTyVar tv = let an = (reverse ops) ++ cps in return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an)) - (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs) - bvis (L lv tv) k)) - chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv))) + (KindedTyVar (an ++ annk ++ ann) bvis (L lv tv) k)) + chk ops cps bvis (L l (HsTyVar ann _ (L ltv tv))) | isRdrTyVar tv = let an = (reverse ops) ++ cps in return (L (widenLocatedAn l (for_widening bvis:an)) - (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs) - bvis (L ltv tv))) - chk _ _ _ _ t@(L loc _) + (UserTyVar (an ++ ann) bvis (L ltv tv))) + chk _ _ _ t@(L loc _) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) @@ -985,11 +983,6 @@ checkTyVars pp_what equals_or_where tc tparms for_widening (HsBndrInvisible (EpTok loc)) = AddEpAnn AnnAnyclass loc for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) - for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn] - for_widening_ann (HsBndrInvisible (EpTok (EpaSpan (RealSrcSpan r _mb)))) - = EpAnn (realSpanAsAnchor r) [] emptyComments - for_widening_ann _ = noAnn - whereDots, equalsDots :: SDoc -- Second argument to checkTyVars @@ -1004,7 +997,7 @@ checkDatatypeContext (Just c) (PsErrIllegalDataTypeContext c) type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) +data RuleTyTmVar = RuleTyTmVar [AddEpAnn] (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward @@ -1523,7 +1516,7 @@ instance DisambInfixOp RdrName where mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole type AnnoBody b - = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnn NoEpAnns + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA @@ -1608,7 +1601,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate "[a,b,c]" (list syntax) mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) - mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b) + mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: Bool -> -- Is OverloadedRecordUpdate in effect? @@ -1833,13 +1826,13 @@ instance DisambECP (HsExpr GhcPs) where mkHsExplicitListPV l xs anns = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs) - mkHsSplicePV sp@(L l _) = do + mkHsSplicePV (L l a) = do cs <- getCommentsFor l - return $ fmap (HsUntypedSplice NoExtField) sp + return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a) mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do cs <- getCommentsFor l r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns - checkRecordSyntax (L (noAnnSrcSpan l) r) + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) mkHsNegAppPV l a anns = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr) @@ -1909,7 +1902,9 @@ instance DisambECP (PatBuilder GhcPs) where ps <- traverse checkLPat xs cs <- getCommentsFor l return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps))) - mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) + mkHsSplicePV (L l sp) = do + cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) ===================================== compiler/GHC/Parser/Types.hs ===================================== @@ -62,7 +62,7 @@ data PatBuilder p | PatBuilderOverLit (HsOverLit GhcPs) -- These instances are here so that they are not orphans -type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnn NoEpAnns +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnnCO type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA ===================================== compiler/GHC/Rename/Bind.hs ===================================== @@ -1242,8 +1242,8 @@ type AnnoBody body , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA - , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnn NoEpAnns - , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnn NoEpAnns + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO + , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnnCO , Outputable (body GhcPs) ) ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -203,8 +203,8 @@ type AnnoBody body , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL - , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnn NoEpAnns - , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnn NoEpAnns + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO + , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA ) ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -850,7 +850,7 @@ zonkLTcSpecPrags ps ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnn NoEpAnns +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) -> MatchGroup GhcTc (LocatedA (body GhcTc)) -> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -864,7 +864,7 @@ zonkMatchGroup zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys' res_ty' origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnn NoEpAnns +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) -> LMatch GhcTc (LocatedA (body GhcTc)) -> ZonkTcM (LMatch GhcTc (LocatedA (body GhcTc))) @@ -875,7 +875,7 @@ zonkMatch zBody (L loc match@(Match { m_pats = pats ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } ------------------------------------------------------------------------- -zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnn NoEpAnns +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) -> GRHSs GhcTc (LocatedA (body GhcTc)) -> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc))) ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -99,11 +99,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:5:22-32 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -163,11 +159,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:5:51-55 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -244,11 +236,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:7:51-60 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -276,11 +264,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:7:65-66 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -329,11 +313,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:7:69-74 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -352,11 +332,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { Test20239.hs:7:76-81 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -73,11 +73,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:5:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -148,11 +144,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:6:9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -180,11 +172,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:6:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -252,11 +240,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:9:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -327,11 +311,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:10:9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -350,11 +330,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:10:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -429,11 +405,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:13:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -504,11 +476,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:14:9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -527,11 +495,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:14:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -609,11 +573,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:17:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -684,11 +644,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:18:9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -707,11 +663,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:18:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -779,11 +731,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:20:9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -802,11 +750,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:20:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -867,11 +811,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:22:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -922,11 +862,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:22:28 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -999,11 +935,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:23:10-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1022,11 +954,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:23:13-15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1077,11 +1005,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:24:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1158,11 +1082,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:25:13-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1181,11 +1101,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:25:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1244,11 +1160,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:28:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1299,11 +1211,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:28:28 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1376,11 +1284,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:29:10-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1399,11 +1303,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:29:13-15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1454,11 +1354,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:30:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1535,11 +1431,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:31:13-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1558,11 +1450,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:31:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1621,11 +1509,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:34:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1676,11 +1560,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:34:28 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1753,11 +1633,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:35:10-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1776,11 +1652,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:35:13-15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1831,11 +1703,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:36:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1912,11 +1780,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:37:13-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1935,11 +1799,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:37:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1998,11 +1858,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:40:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2053,11 +1909,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:40:28 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2130,11 +1982,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:41:10-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2153,11 +2001,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:41:13-15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2208,11 +2052,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:42:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2289,11 +2129,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:43:13-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2312,11 +2148,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:43:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2375,11 +2207,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:46:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2430,11 +2258,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:46:28 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2507,11 +2331,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:47:10-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2530,11 +2350,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:47:13-15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2585,11 +2401,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:48:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2666,11 +2478,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:49:13-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2689,11 +2497,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:49:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2752,11 +2556,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:52:11 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2807,11 +2607,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544.hs:52:30 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2884,11 +2680,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:53:10-12 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2907,11 +2699,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:53:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2962,11 +2750,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:54:12-14 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -3043,11 +2827,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:55:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -3066,11 +2846,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544.hs:55:18-20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -130,11 +130,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544_kw.hs:16:18-20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -261,11 +257,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544_kw.hs:19:24-26 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -330,11 +322,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T17544_kw.hs:21:11 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -392,11 +380,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T17544_kw.hs:24:18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -174,11 +174,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:7:26-30 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -260,11 +256,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:9:17 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -283,11 +275,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:9:23-27 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -376,11 +364,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -408,11 +392,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:15-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -441,11 +421,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:21-24 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -485,11 +461,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:27-32 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -508,11 +480,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:34-35 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -571,11 +539,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:12:21-24 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -606,13 +570,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:10:20-30 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:24-25 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:10:20 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:10:20 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:24-25 }))] (HsBndrRequired (NoExtField)) (L @@ -644,11 +604,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:10:28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -676,11 +632,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:10:35-39 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -727,11 +679,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:8 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -751,13 +699,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:10-17 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:15:13-14 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:15:10 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:15:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:15:13-14 }))] (HsBndrRequired (NoExtField)) (L @@ -777,11 +721,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -861,11 +801,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:26 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -884,11 +820,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -958,11 +890,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:12 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1019,11 +947,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1042,11 +966,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:23-26 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1065,11 +985,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:32-35 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1137,11 +1053,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:7-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1162,11 +1074,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1187,11 +1095,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:15 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1239,11 +1143,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:19 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1262,11 +1162,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:22-26 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1285,11 +1181,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1308,11 +1200,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:30 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1343,13 +1231,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:16-23 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:19-20 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:18:16 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:23 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:18:16 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:23 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:19-20 }))] (HsBndrRequired (NoExtField)) (L @@ -1369,11 +1253,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:22 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1392,13 +1272,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:25-40 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:28-29 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:18:25 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:40 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:18:25 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:18:40 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:28-29 }))] (HsBndrRequired (NoExtField)) (L @@ -1431,11 +1307,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:31 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1454,11 +1326,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:36-39 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1486,11 +1354,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:18:45-48 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1565,11 +1429,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1601,11 +1461,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:25 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1624,11 +1480,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:30-33 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1694,11 +1546,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:23-36 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:22:25-26 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:22:25-26 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:22:23 }) @@ -1707,11 +1555,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:23 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1743,11 +1587,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1766,11 +1606,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:33-36 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1833,11 +1669,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:43 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1856,11 +1688,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:48-51 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1879,11 +1707,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:22:57-60 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1977,11 +1801,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:18-19 }) - [] - (EpaComments - [])) + [] (SpecifiedSpec) (L (EpAnn @@ -2022,11 +1842,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:22 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2045,11 +1861,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:24-25 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2077,11 +1889,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:30 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2100,11 +1908,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:32-33 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2141,11 +1945,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:39-41 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2164,11 +1964,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:43 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2187,11 +1983,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:45 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -217,11 +217,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -311,11 +307,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -341,11 +333,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -373,11 +361,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -416,11 +400,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -438,11 +418,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -497,11 +473,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -530,13 +502,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:12:20-30 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:12:24-25 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:12:20 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:12:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:12:20 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:12:30 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:12:24-25 }))] (HsBndrRequired (NoExtField)) (L @@ -567,11 +535,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -598,11 +562,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -673,11 +633,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -695,11 +651,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -768,11 +720,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -801,11 +749,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -823,11 +767,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -889,11 +829,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { DumpRenamedAst.hs:19:23-36 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:19:25-26 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:19:25-26 }))] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:19:23 }) @@ -902,11 +838,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -935,11 +867,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -957,11 +885,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1019,11 +943,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1041,11 +961,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1063,11 +979,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1150,11 +1062,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:20:18-19 }) - [] - (EpaComments - [])) + [] (SpecifiedSpec) (L (EpAnn @@ -1192,11 +1100,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1214,11 +1118,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1245,11 +1145,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1267,11 +1163,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1307,11 +1199,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1329,11 +1217,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1351,11 +1235,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1400,11 +1280,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:22:8 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1423,13 +1299,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:22:10-17 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:22:13-14 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:22:10 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:22:17 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:22:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:22:17 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:22:13-14 }))] (HsBndrRequired (NoExtField)) (L @@ -1448,11 +1320,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1524,11 +1392,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1546,11 +1410,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1618,11 +1478,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1642,11 +1498,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1666,11 +1518,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1716,11 +1564,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1738,11 +1582,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1760,11 +1600,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1782,11 +1618,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1815,13 +1647,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:25:16-23 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:25:19-20 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:25:16 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:23 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:25:16 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:23 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:25:19-20 }))] (HsBndrRequired (NoExtField)) (L @@ -1840,11 +1668,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1862,13 +1686,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:25:25-40 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:25:28-29 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:25:25 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:40 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:25:25 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:25:40 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:25:28-29 }))] (HsBndrRequired (NoExtField)) (L @@ -1898,11 +1718,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1920,11 +1736,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1951,11 +1763,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2014,11 +1822,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2070,11 +1874,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2092,11 +1892,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2114,11 +1910,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2160,11 +1952,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:28:9 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2213,11 +2001,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:29:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2236,11 +2020,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { DumpRenamedAst.hs:29:12 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -2304,11 +2084,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2338,11 +2114,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2406,11 +2178,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2430,11 +2198,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2471,11 +2235,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2493,11 +2253,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -2515,11 +2271,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -197,11 +197,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:9:8-9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -498,11 +494,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:14:8-9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -762,11 +754,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:21:8-9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1330,15 +1318,11 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:28:22-38 }) - [(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:28:30-31 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpSemis.hs:28:22 })) - ,(AddEpAnn AnnOpenP (EpaSpan { DumpSemis.hs:28:23 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:37 })) - ,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:38 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { DumpSemis.hs:28:22 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpSemis.hs:28:23 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:37 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpSemis.hs:28:38 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:28:30-31 }))] (HsBndrRequired (NoExtField)) (L @@ -1358,11 +1342,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:28:33-36 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1432,11 +1412,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:29:12-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1455,11 +1431,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:29:21-23 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1555,11 +1527,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:8-9 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1578,11 +1546,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1610,11 +1574,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1633,11 +1593,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1669,11 +1625,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:25 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1692,11 +1644,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { DumpSemis.hs:31:30 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -123,11 +123,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:12:7 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -147,11 +143,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:12:11-21 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:12:15-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:12:15-16 }))] (L (EpAnn (EpaSpan { KindSigs.hs:12:11-13 }) @@ -160,11 +152,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:12:11-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -183,11 +171,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:12:18-21 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -218,11 +202,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { KindSigs.hs:11:17 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -279,11 +259,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:10 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -318,11 +294,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:15:16-26 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:20-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:20-21 }))] (L (EpAnn (EpaSpan { KindSigs.hs:15:16-18 }) @@ -331,11 +303,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:16-18 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -354,11 +322,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:23-26 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -378,11 +342,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:29-32 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -401,11 +361,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:15:35-49 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:43-44 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:43-44 }))] (L (EpAnn (EpaSpan { KindSigs.hs:15:35-41 }) @@ -423,11 +379,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:35-39 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -446,11 +398,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:41 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -469,11 +417,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:15:46-49 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -519,11 +463,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:11 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -558,11 +498,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:16:18-28 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:22-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:22-23 }))] (L (EpAnn (EpaSpan { KindSigs.hs:16:18-20 }) @@ -571,11 +507,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:18-20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -594,11 +526,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:25-28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -618,11 +546,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:31-34 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -641,11 +565,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:16:37-51 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:45-46 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:45-46 }))] (L (EpAnn (EpaSpan { KindSigs.hs:16:37-43 }) @@ -663,11 +583,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:37-41 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -686,11 +602,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:43 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -709,11 +621,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:16:48-51 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -773,11 +681,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:19:14-24 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:19:18-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:19:18-19 }))] (L (EpAnn (EpaSpan { KindSigs.hs:19:14-16 }) @@ -786,11 +690,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:19:14-16 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -809,11 +709,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:19:21-24 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -896,11 +792,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:22:9-19 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:13-14 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:13-14 }))] (L (EpAnn (EpaSpan { KindSigs.hs:22:9-11 }) @@ -909,11 +801,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:22:9-11 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -932,11 +820,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:22:16-19 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -968,11 +852,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:22:25-28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1003,11 +883,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:22:34-43 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:37-38 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:37-38 }))] (L (EpAnn (EpaSpan { KindSigs.hs:22:34-35 }) @@ -1030,11 +906,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:22:40-43 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1211,11 +1083,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:26:16-27 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:26:21-22 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:26:21-22 }))] (L (EpAnn (EpaSpan { KindSigs.hs:26:16-19 }) @@ -1224,11 +1092,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:26:16-19 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1247,11 +1111,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:26:24-27 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1311,11 +1171,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:27:16-27 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:21-22 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:21-22 }))] (L (EpAnn (EpaSpan { KindSigs.hs:27:16-19 }) @@ -1324,11 +1180,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:27:16-19 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1347,11 +1199,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:27:24-27 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1370,11 +1218,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:27:30-42 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:36-37 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:36-37 }))] (L (EpAnn (EpaSpan { KindSigs.hs:27:30-34 }) @@ -1383,11 +1227,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:27:30-34 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1406,11 +1246,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:27:39-42 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1456,11 +1292,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { KindSigs.hs:28:12 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -1493,11 +1325,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:28:19-39 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:28:31-32 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:28:31-32 }))] (L (EpAnn (EpaSpan { KindSigs.hs:28:19-29 }) @@ -1518,11 +1346,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:28:20-22 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1541,11 +1365,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:28:25-28 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1576,11 +1396,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:28:35-38 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1599,11 +1415,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:28:42 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1651,11 +1463,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:31:21-31 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:31:25-26 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:31:25-26 }))] (L (EpAnn (EpaSpan { KindSigs.hs:31:21-23 }) @@ -1664,11 +1472,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:31:21-23 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1687,11 +1491,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:31:28-31 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1761,11 +1561,7 @@ (EpaComments [])) (HsKindSig - (EpAnn - (EpaSpan { KindSigs.hs:34:10-21 }) - [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:15-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:15-16 }))] (L (EpAnn (EpaSpan { KindSigs.hs:34:10-13 }) @@ -1774,11 +1570,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:34:10-13 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -1797,11 +1589,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { KindSigs.hs:34:18-21 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T14189.stderr ===================================== @@ -52,11 +52,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { T14189.hs:6:15-16 }) @@ -81,11 +77,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -105,11 +97,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { T14189.hs:6:24-25 }) @@ -133,11 +121,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + (NoExtField) (L (EpAnn (EpaSpan { T14189.hs:6:29 }) @@ -203,11 +187,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -68,11 +68,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T15323.hs:5:19 }) - [] - (EpaComments - [])) + [] (HsBndrRequired (NoExtField)) (L @@ -143,11 +139,7 @@ (EpaComments [])) (UserTyVar - (EpAnn - (EpaSpan { T15323.hs:6:27 }) - [] - (EpaComments - [])) + [] (SpecifiedSpec) (L (EpAnn @@ -200,11 +192,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T15323.hs:6:32-33 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -223,11 +211,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T15323.hs:6:35 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -258,11 +242,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T15323.hs:6:41-52 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -281,11 +261,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T15323.hs:6:54 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -68,13 +68,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:5:14-21 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:5:17-18 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:5:14 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:5:21 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:5:14 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:5:21 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:5:17-18 }))] (HsBndrRequired (NoExtField)) (L @@ -94,11 +90,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:5:20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -182,15 +174,11 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:6:13-22 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:6:17-18 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:6:13 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:6:14 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:21 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:22 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:6:13 })) + ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:6:14 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:21 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:6:22 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:6:17-18 }))] (HsBndrRequired (NoExtField)) (L @@ -210,11 +198,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:6:20 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -308,13 +292,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:8:15-26 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:20-21 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:15 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:26 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:15 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:26 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:20-21 }))] (HsBndrRequired (NoExtField)) (L @@ -334,11 +314,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:8:23-25 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -357,13 +333,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:8:30-45 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:36-37 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:30 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:45 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:30 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:45 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:36-37 }))] (HsBndrRequired (NoExtField)) (L @@ -383,11 +355,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:8:39-44 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -406,13 +374,9 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:8:49-75 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:54-55 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:49 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:75 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:8:49 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:8:75 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:8:54-55 }))] (HsBndrRequired (NoExtField)) (L @@ -458,11 +422,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:8:59-64 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -481,11 +441,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:8:67-72 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -549,15 +505,11 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:9:14-27 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:20-21 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:14 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:15 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:26 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:27 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:14 })) + ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:15 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:26 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:27 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:20-21 }))] (HsBndrRequired (NoExtField)) (L @@ -577,11 +529,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:9:23-25 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -600,15 +548,11 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:9:29-46 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:36-37 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:29 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:30 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:45 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:46 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:29 })) + ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:30 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:45 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:46 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:36-37 }))] (HsBndrRequired (NoExtField)) (L @@ -628,11 +572,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:9:39-44 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -651,15 +591,11 @@ (EpaComments [])) (KindedTyVar - (EpAnn - (EpaSpan { T20452.hs:9:48-76 }) - [(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:54-55 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:48 })) - ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:49 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:75 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:76 }))] - (EpaComments - [])) + [(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:48 })) + ,(AddEpAnn AnnOpenP (EpaSpan { T20452.hs:9:49 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:75 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T20452.hs:9:76 })) + ,(AddEpAnn AnnDcolon (EpaSpan { T20452.hs:9:54-55 }))] (HsBndrRequired (NoExtField)) (L @@ -705,11 +641,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:9:59-64 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -728,11 +660,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T20452.hs:9:67-72 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -122,11 +122,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T18791.hs:5:10-12 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn @@ -145,11 +141,7 @@ (EpaComments [])) (HsTyVar - (EpAnn - (EpaSpan { T18791.hs:5:17 }) - [] - (EpaComments - [])) + [] (NotPromoted) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2204,11 +2204,11 @@ instance ExactPrint (RuleBndr GhcPs) where ln' <- markAnnotated ln return (RuleBndr x ln') exact (RuleBndrSig an ln (HsPS x ty)) = do - an0 <- markEpAnnL an lidl AnnOpenP -- "(" + an0 <- markEpAnnL' an lidl AnnOpenP -- "(" ln' <- markAnnotated ln - an1 <- markEpAnnL an0 lidl AnnDcolon + an1 <- markEpAnnL' an0 lidl AnnDcolon ty' <- markAnnotated ty - an2 <- markEpAnnL an1 lidl AnnCloseP -- ")" + an2 <- markEpAnnL' an1 lidl AnnCloseP -- ")" return (RuleBndrSig an2 ln' (HsPS x ty')) -- --------------------------------------------------------------------- @@ -3941,21 +3941,21 @@ instance ExactPrint (InjectivityAnn GhcPs) where class Typeable flag => ExactPrintTVFlag flag where exactTVDelimiters :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> flag -> EP w m (HsTyVarBndr flag GhcPs) - -> EP w m (EpAnn [AddEpAnn], (HsTyVarBndr flag GhcPs)) + => [AddEpAnn] -> flag -> EP w m (HsTyVarBndr flag GhcPs) + -> EP w m ([AddEpAnn], (HsTyVarBndr flag GhcPs)) instance ExactPrintTVFlag () where exactTVDelimiters an _ thing_inside = do - an0 <- markEpAnnAllL an lid AnnOpenP + an0 <- markEpAnnAllL' an lid AnnOpenP r <- thing_inside - an1 <- markEpAnnAllL an0 lid AnnCloseP + an1 <- markEpAnnAllL' an0 lid AnnCloseP return (an1, r) instance ExactPrintTVFlag Specificity where exactTVDelimiters an s thing_inside = do - an0 <- markEpAnnAllL an lid open + an0 <- markEpAnnAllL' an lid open r <- thing_inside - an1 <- markEpAnnAllL an0 lid close + an1 <- markEpAnnAllL' an0 lid close return (an1, r) where (open, close) = case s of @@ -3967,17 +3967,14 @@ instance ExactPrintTVFlag (HsBndrVis GhcPs) where case bvis of HsBndrRequired _ -> return () HsBndrInvisible at -> markEpToken at >> return () - an1 <- markEpAnnAllL an0 lid AnnOpenP + an1 <- markEpAnnAllL' an0 lid AnnOpenP r <- thing_inside - an2 <- markEpAnnAllL an1 lid AnnCloseP + an2 <- markEpAnnAllL' an1 lid AnnCloseP return (an2, r) instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where - getAnnotationEntry (UserTyVar an _ _) = fromAnn an - getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an - - setAnnotationAnchor (UserTyVar an a b) anc ts cs = UserTyVar (setAnchorEpa an anc ts cs) a b - setAnnotationAnchor (KindedTyVar an a b c) anc ts cs = KindedTyVar (setAnchorEpa an anc ts cs) a b c + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (UserTyVar an flag n) = do r <- exactTVDelimiters an flag $ do @@ -3989,7 +3986,7 @@ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where exact (KindedTyVar an flag n k) = do r <- exactTVDelimiters an flag $ do n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon k' <- markAnnotated k return (KindedTyVar an0 flag n' k') case r of @@ -3999,53 +3996,8 @@ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (HsType GhcPs) where - getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal - getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal - getAnnotationEntry (HsTyVar an _ _) = fromAnn an - getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal - getAnnotationEntry (HsFunTy _ _ _ _) = NoEntryVal - getAnnotationEntry (HsListTy _ _) = NoEntryVal - getAnnotationEntry (HsTupleTy _ _ _) = NoEntryVal - getAnnotationEntry (HsSumTy _ _) = NoEntryVal - getAnnotationEntry (HsOpTy _ _ _ _ _) = NoEntryVal - getAnnotationEntry (HsParTy _ _) = NoEntryVal - getAnnotationEntry (HsIParamTy _ _ _) = NoEntryVal - getAnnotationEntry (HsStarTy _ _) = NoEntryVal - getAnnotationEntry (HsKindSig an _ _) = fromAnn an - getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal - getAnnotationEntry (HsDocTy _ _ _) = NoEntryVal - getAnnotationEntry (HsBangTy _ _ _) = NoEntryVal - getAnnotationEntry (HsRecTy _ _) = NoEntryVal - getAnnotationEntry (HsExplicitListTy _ _ _) = NoEntryVal - getAnnotationEntry (HsExplicitTupleTy _ _) = NoEntryVal - getAnnotationEntry (HsTyLit _ _) = NoEntryVal - getAnnotationEntry (HsWildCardTy _) = NoEntryVal - getAnnotationEntry (XHsType _) = NoEntryVal - - setAnnotationAnchor a@(HsForAllTy _ _ _) _ _ _s = a - setAnnotationAnchor a@(HsQualTy _ _ _) _ _ _s = a - setAnnotationAnchor (HsTyVar an a b) anc ts cs = (HsTyVar (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(HsAppTy _ _ _) _ _ _s = a - setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _ _s = a - setAnnotationAnchor a@(HsFunTy{}) _ _ _s = a - setAnnotationAnchor a@(HsListTy{}) _ _ _s = a - setAnnotationAnchor a@(HsTupleTy{}) _ _ _s = a - setAnnotationAnchor a@(HsSumTy{}) _ _ _s = a - setAnnotationAnchor a@(HsOpTy{}) _ _ _s = a - setAnnotationAnchor a@(HsParTy{}) _ _ _s = a - setAnnotationAnchor a@(HsIParamTy{}) _ _ _s = a - setAnnotationAnchor a@(HsStarTy _ _) _ _ _s = a - setAnnotationAnchor (HsKindSig an a b) anc ts cs = (HsKindSig (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(HsSpliceTy _ _) _ _ _s = a - setAnnotationAnchor a@(HsDocTy{}) _ _ _s = a - setAnnotationAnchor a@(HsBangTy{}) _ _ _s = a - setAnnotationAnchor a@(HsRecTy{}) _ _ _s = a - setAnnotationAnchor a@(HsExplicitListTy{}) _ _ _s = a - setAnnotationAnchor a@(HsExplicitTupleTy{}) _ _ _s = a - setAnnotationAnchor a@(HsTyLit _ _) _ _ _s = a - setAnnotationAnchor a@(HsWildCardTy _) _ _ _s = a - setAnnotationAnchor a@(XHsType _) _ _ _s = a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a exact (HsForAllTy { hst_xforall = an , hst_tele = tele, hst_body = ty }) = do @@ -4060,7 +4012,7 @@ instance ExactPrint (HsType GhcPs) where return (HsQualTy an ctxt' ty') exact (HsTyVar an promoted name) = do an0 <- if (promoted == IsPromoted) - then markEpAnnL an lidl AnnSimpleQuote + then markEpAnnL' an lidl AnnSimpleQuote else return an name' <- markAnnotated name return (HsTyVar an0 promoted name') @@ -4118,7 +4070,7 @@ instance ExactPrint (HsType GhcPs) where return (HsStarTy an isUnicode) exact (HsKindSig an ty k) = do ty' <- markAnnotated ty - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon k' <- markAnnotated k return (HsKindSig an0 ty' k') exact (HsSpliceTy a splice) = do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e848e044e94eeed1fc54c32edf436cdf175ca1c1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e848e044e94eeed1fc54c32edf436cdf175ca1c1 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 Dec 11 06:19:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 01:19:34 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: Comments only in FloatIn Message-ID: <6576a9f66b32c_3478bc678471704518e9@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 088c88a1 by Vladislav Zavialov at 2023-12-11T01:19:28-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. - - - - - d4d49b49 by Zubin Duggal at 2023-12-11T01:19:28-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 - - - - - fb6e44fa by Zubin Duggal at 2023-12-11T01:19:28-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 - - - - - 34988a10 by Zubin Duggal at 2023-12-11T01:19:28-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 - - - - - 22070fc0 by Zubin Duggal at 2023-12-11T01:19:28-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 - - - - - 33e5388e by Zubin Duggal at 2023-12-11T01:19:28-05:00 compiler: Force IfGlobalRdrEnv in NFData instance. - - - - - 30 changed files: - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Utils/Lexeme.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/using-warnings.rst - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - testsuite/tests/rename/should_compile/T20609.hs → testsuite/tests/parser/should_fail/T20609.hs - + testsuite/tests/parser/should_fail/T20609.stderr - testsuite/tests/rename/should_compile/T20609a.hs → testsuite/tests/parser/should_fail/T20609a.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b4c8371e581c3c4dd1507ab0631d665efa60828b...33e5388ec5109ebf46c7e83e31d8ec269006967c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b4c8371e581c3c4dd1507ab0631d665efa60828b...33e5388ec5109ebf46c7e83e31d8ec269006967c 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 Dec 11 09:20:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 04:20:01 -0500 Subject: [Git][ghc/ghc][master] Make forall a keyword (#23719) Message-ID: <6576d440f40a6_3478bc6b578260468957@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 30 changed files: - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Utils/Lexeme.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/using-warnings.rst - testsuite/tests/rename/should_compile/T20609.hs → testsuite/tests/parser/should_fail/T20609.hs - + testsuite/tests/parser/should_fail/T20609.stderr - testsuite/tests/rename/should_compile/T20609a.hs → testsuite/tests/parser/should_fail/T20609a.hs - + testsuite/tests/parser/should_fail/T20609a.stderr - testsuite/tests/rename/should_compile/T20609b.hs → testsuite/tests/parser/should_fail/T20609b.hs - + testsuite/tests/parser/should_fail/T20609b.stderr - testsuite/tests/rename/should_compile/T20609c.hs → testsuite/tests/parser/should_fail/T20609c.hs - + testsuite/tests/parser/should_fail/T20609c.stderr - testsuite/tests/rename/should_compile/T20609d.hs → testsuite/tests/parser/should_fail/T20609d.hs - + testsuite/tests/parser/should_fail/T20609d.stderr - testsuite/tests/parser/should_fail/all.T - testsuite/tests/printer/PprUnicodeSyntax.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9e4c5978238322934fa0e2677f32d44841b822d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9e4c5978238322934fa0e2677f32d44841b822d 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 Dec 11 09:21:03 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 04:21:03 -0500 Subject: [Git][ghc/ghc][master] 5 commits: driver: Ensure we actually clear the interactive context before reloading Message-ID: <6576d47f12040_3478bc6b579cdc4775fc@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 9 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Data/Bag.hs ===================================== @@ -40,6 +40,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq infixr 3 `consBag` infixl 3 `snocBag` @@ -51,6 +52,12 @@ data Bag a | ListBag (NonEmpty a) deriving (Foldable, Functor, Traversable) +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a + emptyBag :: Bag a emptyBag = EmptyBag ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -771,6 +771,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env + hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env @@ -780,7 +781,6 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do worker_limit <- liftIO $ mkWorkerLimit dflags - setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan @@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map - let build_action = - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps + let !build_action = case mod of InstantiationNode uid iu -> do - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> do + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) + ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) + in withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- This global MVar is incrementally modified in order to avoid having to + -- recreate the HPT before compiling each module which leads to a quadratic amount of work. + liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) + return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $ (MakeAction build_action res_var) + return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] @@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a)) +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -574,6 +574,9 @@ data GlobalRdrEltX info -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -620,18 +623,19 @@ greParent = gre_par greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where - rnf !_ = () - -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -934,11 +938,10 @@ globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. @@ -1916,25 +1919,28 @@ instance Semigroup ShadowedGREs where -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1945,8 +1951,8 @@ data ImpItemSpec -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -575,11 +575,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules ===================================== testsuite/tests/ghci/T23405/T23405.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23405 (test) where + +import Language.Haskell.TH + +test :: IO () +test = do + let s = $(getDoc (DeclDoc ''Double) >>= \doc -> [|doc|]) + print (s `seq` ()) + + ===================================== testsuite/tests/ghci/T23405/T23405.script ===================================== @@ -0,0 +1,3 @@ +:load T23405.hs +:! echo -- an extra comment so that the hash changes >> T23405.hs +:reload ===================================== testsuite/tests/ghci/T23405/all.T ===================================== @@ -0,0 +1 @@ +test('T23405', [extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) ===================================== testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciReload.script ===================================== @@ -0,0 +1,4 @@ +:set -fforce-recomp +:l MultiLayerModules.hs +:r +:r ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -394,6 +394,19 @@ test('MultiLayerModulesDefsGhci', ghci_script, ['MultiLayerModulesDefsGhci.script']) +test('MultiLayerModulesDefsGhciReload', + [ collect_compiler_residency(15), + pre_cmd('./genMultiLayerModulesDefs'), + extra_files(['genMultiLayerModulesDefs']), + compile_timeout_multiplier(5) + # this is _a lot_ + # but this test has been failing every now and then, + # especially on i386. Let's just give it some room + # to complete successfully reliably everywhere. + ], + ghci_script, + ['MultiLayerModulesDefsGhciReload.script']) + test('InstanceMatching', [ collect_compiler_stats('bytes allocated',3), pre_cmd('$MAKE -s --no-print-directory InstanceMatching'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d9e4c5978238322934fa0e2677f32d44841b822d...522c12a43b34ad4ca7f3f916fa630d33a4fe6efb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d9e4c5978238322934fa0e2677f32d44841b822d...522c12a43b34ad4ca7f3f916fa630d33a4fe6efb 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 Dec 11 12:17:53 2023 From: gitlab at gitlab.haskell.org (Oleg Grenrus (@phadej)) Date: Mon, 11 Dec 2023 07:17:53 -0500 Subject: [Git][ghc/ghc][wip/T24190] 27 commits: Only exit ghci in -e mode when :add command fails Message-ID: <6576fdf18af1b_3478bc702cea8c498171@gitlab.mail> Oleg Grenrus pushed to branch wip/T24190 at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - c3bac796 by Oleg Grenrus at 2023-12-11T14:17:44+02: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. - - - - - 30 changed files: - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Pmc/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afe3e1203a963743a1f1b34d13c95438350e89a1...c3bac796b7a12907f0e88d99d183518945a85a77 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afe3e1203a963743a1f1b34d13c95438350e89a1...c3bac796b7a12907f0e88d99d183518945a85a77 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 Dec 11 14:54:04 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 09:54:04 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Make forall a keyword (#23719) Message-ID: <6577228cab56d_3478bc739a1ac85278c6@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - c3bac796 by Oleg Grenrus at 2023-12-11T14:17:44+02: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. - - - - - 4062551a by Vladislav Zavialov at 2023-12-11T09:54:00-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. - - - - - 30 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Utils/Lexeme.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/bugs.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - + testsuite/tests/ghci/T23405/T23405.hs - + testsuite/tests/ghci/T23405/T23405.script - + testsuite/tests/ghci/T23405/all.T - testsuite/tests/rename/should_compile/T20609.hs → testsuite/tests/parser/should_fail/T20609.hs - + testsuite/tests/parser/should_fail/T20609.stderr - testsuite/tests/rename/should_compile/T20609a.hs → testsuite/tests/parser/should_fail/T20609a.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/33e5388ec5109ebf46c7e83e31d8ec269006967c...4062551ae94d3d787a8fc1bcba9c2ac3e5b1d70b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/33e5388ec5109ebf46c7e83e31d8ec269006967c...4062551ae94d3d787a8fc1bcba9c2ac3e5b1d70b 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 Dec 11 14:56:17 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Mon, 11 Dec 2023 09:56:17 -0500 Subject: [Git][ghc/ghc][wip/DataToTagSmallOp] 2 commits: Qualify "no advantage" slightly for dataToTagSmall# Message-ID: <65772311af77e_3478bc73fbdfd853316@gitlab.mail> Matthew Craven pushed to branch wip/DataToTagSmallOp at Glasgow Haskell Compiler / GHC Commits: 52f12e91 by Matthew Craven at 2023-12-11T09:54:25-05:00 Qualify "no advantage" slightly for dataToTagSmall# - - - - - f383a631 by Matthew Craven at 2023-12-11T09:55:41-05:00 Address more review comments - - - - - 3 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Tc/Instance/Class.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3692,7 +3692,7 @@ section "Tag to enum stuff" primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! - This one offers /no advantage/ and comes with no stability + This one normally offers /no advantage/ and comes with no stability guarantees: it may change its type, its name, or its behavior with /no warning/ between compiler releases. ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,12 +1131,13 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies conditions DTT2 +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 -- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -702,8 +702,7 @@ these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTag# primops remain exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. + While wrinkle DTW7 is unresolved, this cannot be a true invariant. But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. @@ -802,7 +801,7 @@ Wrinkles: few enough contructors that the tag always fits in the pointer. * dataToTagLarge# also consults the tag bits in the pointer, but - must fall back te examining the info table whenever those tag + must fall back to examining the info table whenever those tag bits are equal to mAX_PTR_TAG. One could imagine having one primop with a small/large tag, or just @@ -851,7 +850,7 @@ Wrinkles: dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 Why do these exist? GHCi uses these symbols for... something. There - is on-going work to get rid of them. See also #24169 and !6245. + is on-going work to get rid of them. See also #24169, #20155, and !6245. Their continued existence makes it difficult to do several nice things: * As explained in DTW6, the dataToTag# primops are very internal. @@ -863,7 +862,9 @@ Wrinkles: variable `a_levpoly` in the above definitions. In particular, they do not satisfy conditions DTT2 and DTT3 above. We would very much like these conditions to be invariants, but while - GHC.PrimopWrappers breaks them we cannot do so. + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` must check for condition DTT2 before doing the work described in View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfbd33d9a3af8c2866d1215937957a0a0c4d1457...f383a631045e3d89904444c730f775633fdef114 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bfbd33d9a3af8c2866d1215937957a0a0c4d1457...f383a631045e3d89904444c730f775633fdef114 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 Dec 11 14:57:12 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Mon, 11 Dec 2023 09:57:12 -0500 Subject: [Git][ghc/ghc][wip/DataToTagSmallOp] 2 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <65772348d860f_3478bc73fb621053355e@gitlab.mail> Matthew Craven pushed to branch wip/DataToTagSmallOp at Glasgow Haskell Compiler / GHC Commits: 533cf0a0 by Matthew Craven at 2023-12-11T09:56:31-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 - - - - - 3a324b0e by Matthew Craven at 2023-12-11T09:56:41-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 17 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,23 +1131,29 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -638,9 +634,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -851,6 +848,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,36 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +742,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +762,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +789,93 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +901,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +914,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f383a631045e3d89904444c730f775633fdef114...3a324b0e551c5fe60cce904d841777374117a5d5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f383a631045e3d89904444c730f775633fdef114...3a324b0e551c5fe60cce904d841777374117a5d5 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 Dec 11 19:14:56 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 14:14:56 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <65775fb0d7451_3478bc79e5cb48562690@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 297c93b0 by Matthew Craven at 2023-12-11T14:14:28-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 - - - - - f80e4e70 by Matthew Craven at 2023-12-11T14:14:28-05:00 Fix formatting of Note [alg-alt heap check] - - - - - baa76a83 by Oleg Grenrus at 2023-12-11T14:14:29-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. - - - - - 1f21c8b3 by Vladislav Zavialov at 2023-12-11T14:14:29-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. - - - - - 26 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,23 +1131,29 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,38 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +125,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +154,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -666,9 +662,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -879,6 +876,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,36 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +742,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +762,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +789,93 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +901,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +914,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,33 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2440,8 +2440,8 @@ of ``-W(no-)*``. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification that would stop working under :extension:`RequiredTypeArguments`. ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -599,3 +599,4 @@ test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) test('T23719', normal, compile_fail, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4062551ae94d3d787a8fc1bcba9c2ac3e5b1d70b...1f21c8b3b047e706323adb965a779fd2640cdd74 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4062551ae94d3d787a8fc1bcba9c2ac3e5b1d70b...1f21c8b3b047e706323adb965a779fd2640cdd74 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 Dec 11 21:34:51 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Mon, 11 Dec 2023 16:34:51 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] 2 commits: EPA: Starting to remove EpAnn from Decl extension points Message-ID: <6577807b6f860_3478bc7d6a13f0570236@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 2ca4bc86 by Alan Zimmerman at 2023-12-10T23:11:11+00:00 EPA: Starting to remove EpAnn from Decl extension points - - - - - e7fec482 by Alan Zimmerman at 2023-12-11T21:33:36+00:00 EPA: Removing more EpAnn from Decls extension points - - - - - 14 changed files: - compiler/GHC/Hs/Decls.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/printer/T18791.stderr - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -338,11 +338,11 @@ instance Outputable SpliceDecoration where type instance XFamDecl (GhcPass _) = NoExtField -type instance XSynDecl GhcPs = EpAnn [AddEpAnn] +type instance XSynDecl GhcPs = [AddEpAnn] type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = EpAnn [AddEpAnn] +type instance XDataDecl GhcPs = [AddEpAnn] type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn @@ -353,7 +353,7 @@ data DataDeclRn = DataDeclRn deriving Data type instance XClassDecl GhcPs = - ( EpAnn [AddEpAnn] + ( [AddEpAnn] , EpLayout -- See Note [Class EpLayout] , AnnSortKey DeclTag ) -- TODO:AZ:tidy up AnnSortKey @@ -807,7 +807,7 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ************************************************************************ -} -type instance XCFamEqn (GhcPass _) r = EpAnn [AddEpAnn] +type instance XCFamEqn (GhcPass _) r = [AddEpAnn] type instance XXFamEqn (GhcPass _) r = DataConCantHappen type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA @@ -818,7 +818,7 @@ type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs) -- The warning of the deprecated instance -- See Note [Implementation of deprecated instances] -- in GHC.Tc.Solver.Dict - , EpAnn [AddEpAnn] + , [AddEpAnn] , AnnSortKey DeclTag) -- For sorting the additional annotations -- TODO:AZ:tidy up type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn) @@ -1274,13 +1274,13 @@ pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) ************************************************************************ -} -type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XWarnings GhcPs = ([AddEpAnn], SourceText) type instance XWarnings GhcRn = SourceText type instance XWarnings GhcTc = SourceText type instance XXWarnDecls (GhcPass _) = DataConCantHappen -type instance XWarning (GhcPass _) = EpAnn [AddEpAnn] +type instance XWarning (GhcPass _) = [AddEpAnn] type instance XXWarnDecl (GhcPass _) = DataConCantHappen @@ -1313,7 +1313,7 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText) +type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where @@ -1335,7 +1335,7 @@ pprAnnProvenance (TypeAnnProvenance (L _ name)) ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn] +type instance XCRoleAnnotDecl GhcPs = [AddEpAnn] type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField ===================================== compiler/GHC/Parser.y ===================================== @@ -1257,8 +1257,8 @@ topdecl :: { LHsDecl GhcPs } | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $> (DefD noExtField (DefaultDecl (EpAnn (glEE $1 $>) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) } | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glEE $1 $>) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) } - | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) } - | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) } + | '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getDEPRECATED_PRAGs $1)) (fromOL $2))) } + | '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getWARNING_PRAGs $1)) (fromOL $2))) } | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) } | annotation { $1 } | decl_no_th { $1 } @@ -1347,15 +1347,15 @@ inst_decl :: { LInstDecl GhcPs } : 'instance' maybe_warning_pragma overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5) ; let anns = (mj AnnInstance $1 : (fst $ unLoc $5)) - ; let cid cs = ClsInstDecl - { cid_ext = ($2, EpAnn (spanAsAnchor (comb3 $1 $4 $5)) anns cs, NoAnnSortKey) - , cid_poly_ty = $4, cid_binds = binds - , cid_sigs = mkClassOpSigs sigs - , cid_tyfam_insts = ats - , cid_overlap_mode = $3 - , cid_datafam_insts = adts } - ; acsA (\cs -> L (comb3 $1 $4 $5) - (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs })) + ; let cid = ClsInstDecl + { cid_ext = ($2, anns, NoAnnSortKey) + , cid_poly_ty = $4, cid_binds = binds + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats + , cid_overlap_mode = $3 + , cid_datafam_insts = adts } + ; amsA' (L (comb3 $1 $4 $5) + (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) } } -- type instance declarations @@ -2002,8 +2002,8 @@ warnings :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namelist strings - {% fmap unitOL $ acsA (\cs -> L (comb3 $1 $2 $3) - (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2) + {% fmap unitOL $ amsA' (L (comb3 $1 $2 $3) + (Warning (fst $ unLoc $3) (unLoc $2) (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) } deprecations :: { OrdList (LWarnDecl GhcPs) } @@ -2026,7 +2026,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glEE $1 $>) (fst $ unLoc $2) cs) (unLoc $1) + {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (fst $ unLoc $2) (unLoc $1) (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } strings :: { Located ([AddEpAnn],[Located StringLiteral]) } @@ -2052,19 +2052,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $4) []) cs), + (AnnPragma (mo $1) (mc $4) [], (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs), + (AnnPragma (mo $1) (mc $5) [mj AnnType $2], (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation - ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs), + (AnnPragma (mo $1) (mc $4) [mj AnnModule $2], (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -203,8 +203,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; tyvars <- checkTyVars (text "class") whereDots cls tparams - ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs + ; let anns' = annsIn Semi.<> ann ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey) , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars @@ -230,8 +229,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) = do { let loc = noAnnSrcSpan loc' ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams - ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs + ; let anns' = annsIn Semi.<> ann ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdDExt = anns', @@ -261,10 +259,8 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; tyvars <- checkTyVars (text "type") equalsDots tc tparams - ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) + ; let anns' = annsIn Semi.<> ann ; return (L (noAnnSrcSpan loc) (SynDecl { tcdSExt = anns' , tcdLName = tc, tcdTyVars = tyvars @@ -304,9 +300,8 @@ mkTyFamInstEqn :: SrcSpan -> P (LTyFamInstEqn GhcPs) mkTyFamInstEqn loc bndrs lhs rhs anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs <- getCommentsFor loc ; return (L (noAnnSrcSpan loc) $ FamEqn - { feqn_ext = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs + { feqn_ext = anns `mappend` ann , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -326,12 +321,10 @@ mkDataFamInst :: SrcSpan mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) ksig data_cons (L _ maybe_deriv) anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan - ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl - (FamEqn { feqn_ext = fam_eqn_ans + (FamEqn { feqn_ext = ann Semi.<> anns , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -425,8 +418,8 @@ mkRoleAnnotDecl :: SrcSpan mkRoleAnnotDecl loc tycon roles anns = do { roles' <- mapM parse_role roles ; cs <- getCommentsFor loc - ; return $ L (noAnnSrcSpan loc) - $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' } + ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs) + $ RoleAnnotDecl anns tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -58,26 +58,23 @@ (EpaComment (EpaLineComment "-- Running over two lines") - { Test20239.hs:3:1-28 }))])) + { Test20239.hs:3:1-28 })) + ,(L + (EpaSpan + { Test20239.hs:6:34-70 }) + (EpaComment + (EpaLineComment + "-- ^ Run a query against the database") + { Test20239.hs:5:51-55 }))])) (InstD (NoExtField) (DataFamInstD (NoExtField) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { Test20239.hs:(5,1)-(7,86) }) - [(AddEpAnn AnnData (EpaSpan { Test20239.hs:5:1-4 })) - ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:5:6-13 })) - ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:5:34 }))] - (EpaComments - [(L - (EpaSpan - { Test20239.hs:6:34-70 }) - (EpaComment - (EpaLineComment - "-- ^ Run a query against the database") - { Test20239.hs:5:51-55 }))])) + [(AddEpAnn AnnData (EpaSpan { Test20239.hs:5:1-4 })) + ,(AddEpAnn AnnInstance (EpaSpan { Test20239.hs:5:6-13 })) + ,(AddEpAnn AnnEqual (EpaSpan { Test20239.hs:5:34 }))] (L (EpAnn (EpaSpan { Test20239.hs:5:15-20 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -44,12 +44,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:(5,1)-(6,16) }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:5:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:5:12-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:5:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:5:12-16 }))] (EpVirtualBraces (3)) (NoAnnSortKey)) @@ -211,12 +207,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:(9,1)-(10,16) }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:9:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:9:12-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:9:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:9:12-16 }))] (EpVirtualBraces (3)) (NoAnnSortKey)) @@ -376,12 +368,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:(13,1)-(14,16) }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:13:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:13:12-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:13:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:13:12-16 }))] (EpVirtualBraces (3)) (NoAnnSortKey)) @@ -544,12 +532,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:(17,1)-(20,16) }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:17:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:17:12-16 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:17:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:17:12-16 }))] (EpVirtualBraces (3)) (NoAnnSortKey)) @@ -777,14 +761,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:22:1-30 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:22:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:22:12-16 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:22:18 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:22:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:22:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:22:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:22:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:22:30 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:22:18 })) @@ -900,12 +880,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(23,1)-(25,18) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:23:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:23:17-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:23:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:23:17-21 }))] (NoAnnSortKey)) (L (EpAnn @@ -978,12 +954,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(24,3)-(25,18) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:24:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:24:15-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:24:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:24:15-19 }))] (L (EpAnn (EpaSpan { T17544.hs:24:8-9 }) @@ -1126,14 +1098,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:28:1-30 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:28:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:28:12-16 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:28:18 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:28:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:28:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:28:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:28:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:28:30 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:28:18 })) @@ -1249,12 +1217,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(29,1)-(31,18) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:29:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:29:17-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:29:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:29:17-21 }))] (NoAnnSortKey)) (L (EpAnn @@ -1327,12 +1291,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(30,3)-(31,18) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:30:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:30:15-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:30:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:30:15-19 }))] (L (EpAnn (EpaSpan { T17544.hs:30:8-9 }) @@ -1475,14 +1435,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:34:1-30 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:34:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:34:12-16 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:34:18 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:34:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:34:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:34:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:34:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:34:30 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:34:18 })) @@ -1598,12 +1554,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(35,1)-(37,18) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:35:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:35:17-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:35:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:35:17-21 }))] (NoAnnSortKey)) (L (EpAnn @@ -1676,12 +1628,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(36,3)-(37,18) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:36:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:36:15-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:36:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:36:15-19 }))] (L (EpAnn (EpaSpan { T17544.hs:36:8-9 }) @@ -1824,14 +1772,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:40:1-30 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:40:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:40:12-16 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:40:18 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:40:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:40:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:40:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:40:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:40:30 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:40:18 })) @@ -1947,12 +1891,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(41,1)-(43,18) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:41:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:41:17-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:41:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:41:17-21 }))] (NoAnnSortKey)) (L (EpAnn @@ -2025,12 +1965,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(42,3)-(43,18) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:42:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:42:15-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:42:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:42:15-19 }))] (L (EpAnn (EpaSpan { T17544.hs:42:8-9 }) @@ -2173,14 +2109,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:46:1-30 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:46:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:46:12-16 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:46:18 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:46:30 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:46:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:46:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:46:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:46:30 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:46:18 })) @@ -2296,12 +2228,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(47,1)-(49,18) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:47:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:47:17-21 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:47:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:47:17-21 }))] (NoAnnSortKey)) (L (EpAnn @@ -2374,12 +2302,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(48,3)-(49,18) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:48:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:48:15-19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:48:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:48:15-19 }))] (L (EpAnn (EpaSpan { T17544.hs:48:8-9 }) @@ -2522,14 +2446,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544.hs:52:1-32 }) - [(AddEpAnn AnnClass (EpaSpan { T17544.hs:52:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:52:13-17 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:52:19 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:52:32 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:52:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:52:13-17 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:52:19 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:52:32 }))] (EpExplicitBraces (EpTok (EpaSpan { T17544.hs:52:19 })) @@ -2645,12 +2565,8 @@ (ClsInstDecl ((,,) (Nothing) - (EpAnn - (EpaSpan { T17544.hs:(53,1)-(55,20) }) - [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:53:1-8 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:53:18-22 }))] - (EpaComments - [])) + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:53:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:53:18-22 }))] (NoAnnSortKey)) (L (EpAnn @@ -2723,12 +2639,8 @@ [])) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { T17544.hs:(54,3)-(55,20) }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:54:3-6 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:54:16-20 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:54:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:54:16-20 }))] (L (EpAnn (EpaSpan { T17544.hs:54:8-10 }) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -55,12 +55,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T17544_kw.hs:(15,1)-(16,20) }) - [(AddEpAnn AnnData (EpaSpan { T17544_kw.hs:15:1-4 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:16:3-7 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544_kw.hs:15:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:16:3-7 }))] (L (EpAnn (EpaSpan { T17544_kw.hs:15:6-8 }) @@ -165,12 +161,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T17544_kw.hs:(18,1)-(19,26) }) - [(AddEpAnn AnnNewtype (EpaSpan { T17544_kw.hs:18:1-7 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:19:3-7 }))] - (EpaComments - [])) + [(AddEpAnn AnnNewtype (EpaSpan { T17544_kw.hs:18:1-7 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:19:3-7 }))] (L (EpAnn (EpaSpan { T17544_kw.hs:18:9-11 }) @@ -293,12 +285,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T17544_kw.hs:(21,1)-(24,18) }) - [(AddEpAnn AnnClass (EpaSpan { T17544_kw.hs:21:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:23:3-7 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T17544_kw.hs:21:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:23:3-7 }))] (EpVirtualBraces (5)) (NoAnnSortKey)) ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -78,12 +78,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { DumpParsedAst.hs:7:1-30 }) - [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:7:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:7:12 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:7:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:7:12 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:7:6-10 }) @@ -316,11 +312,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaSpan { DumpParsedAst.hs:11:3-36 }) - [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:11:19 }))] - (EpaComments - [])) + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:11:19 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:3-8 }) @@ -499,11 +491,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaSpan { DumpParsedAst.hs:12:3-24 }) - [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:12:19 }))] - (EpaComments - [])) + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:12:19 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:12:3-8 }) @@ -654,12 +642,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:1-29 }) - [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:15:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:15:19 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:15:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:15:19 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:15:6 }) @@ -1026,11 +1010,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaSpan { DumpParsedAst.hs:19:3-30 }) - [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:19:17 }))] - (EpaComments - [])) + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:19:17 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:19:3-4 }) @@ -1505,14 +1485,10 @@ (NoExtField) (DataFamInstDecl (FamEqn - (EpAnn - (EpaSpan { DumpParsedAst.hs:(22,1)-(23,45) }) - [(AddEpAnn AnnNewtype (EpaSpan { DumpParsedAst.hs:22:1-7 })) - ,(AddEpAnn AnnInstance (EpaSpan { DumpParsedAst.hs:22:9-16 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:22:39-40 })) - ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:22:62-66 }))] - (EpaComments - [])) + [(AddEpAnn AnnNewtype (EpaSpan { DumpParsedAst.hs:22:1-7 })) + ,(AddEpAnn AnnInstance (EpaSpan { DumpParsedAst.hs:22:9-16 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:22:39-40 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:22:62-66 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:22:18-20 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -259,11 +259,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:3-8 }) @@ -436,11 +432,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:14:3-8 }) @@ -791,11 +783,7 @@ (NoExtField) (DataFamInstDecl (FamEqn - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:19:18-20 }) @@ -1452,11 +1440,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:26:3-4 }) @@ -2141,11 +2125,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpRenamedAst.hs:32:8 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -1289,12 +1289,8 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { DumpSemis.hs:(28,1)-(29,23) }) - [(AddEpAnn AnnClass (EpaSpan { DumpSemis.hs:28:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { DumpSemis.hs:28:40-44 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { DumpSemis.hs:28:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpSemis.hs:28:40-44 }))] (EpVirtualBraces (3)) (NoAnnSortKey)) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -97,11 +97,7 @@ (EpaComments [])) (FamEqn - (EpAnn - (EpaSpan { KindSigs.hs:12:3-21 }) - [(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:12:9 }))] - (EpaComments - [])) + [(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:12:9 }))] (L (EpAnn (EpaSpan { KindSigs.hs:12:3-5 }) @@ -234,12 +230,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:15:1-51 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:15:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:15:12 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:15:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:15:12 }))] (L (EpAnn (EpaSpan { KindSigs.hs:15:6-8 }) @@ -438,12 +430,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:16:1-54 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:16:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:16:13 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:16:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:16:13 }))] (L (EpAnn (EpaSpan { KindSigs.hs:16:6-9 }) @@ -642,12 +630,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:19:1-26 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:19:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:19:10 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:19:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:19:10 }))] (L (EpAnn (EpaSpan { KindSigs.hs:19:6-8 }) @@ -1044,12 +1028,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:26:1-29 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:26:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:26:11 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:26:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:26:11 }))] (L (EpAnn (EpaSpan { KindSigs.hs:26:6-9 }) @@ -1132,12 +1112,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:27:1-45 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:27:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:27:12 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:27:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:27:12 }))] (L (EpAnn (EpaSpan { KindSigs.hs:27:6-10 }) @@ -1267,12 +1243,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:28:1-44 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:28:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:28:14 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:28:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:28:14 }))] (L (EpAnn (EpaSpan { KindSigs.hs:28:6-10 }) @@ -1436,12 +1408,8 @@ (TyClD (NoExtField) (SynDecl - (EpAnn - (EpaSpan { KindSigs.hs:31:1-31 }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:31:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:31:19 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:31:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:31:19 }))] (L (EpAnn (EpaSpan { KindSigs.hs:31:6-17 }) ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -43,12 +43,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T15323.hs:(5,1)-(6,54) }) - [(AddEpAnn AnnData (EpaSpan { T15323.hs:5:1-4 })) - ,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:5:21-25 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T15323.hs:5:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:5:21-25 }))] (L (EpAnn (EpaSpan { T15323.hs:5:6-17 }) ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -43,12 +43,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T20452.hs:5:1-31 }) - [(AddEpAnn AnnData (EpaSpan { T20452.hs:5:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:5:24 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T20452.hs:5:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:5:24 }))] (L (EpAnn (EpaSpan { T20452.hs:5:6-11 }) @@ -149,12 +145,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T20452.hs:6:1-31 }) - [(AddEpAnn AnnData (EpaSpan { T20452.hs:6:1-4 })) - ,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:6:24 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T20452.hs:6:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { T20452.hs:6:24 }))] (L (EpAnn (EpaSpan { T20452.hs:6:6-11 }) @@ -258,14 +250,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T20452.hs:8:1-85 }) - [(AddEpAnn AnnClass (EpaSpan { T20452.hs:8:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:8:78-82 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:8:84 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:8:85 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T20452.hs:8:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:8:78-82 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:8:84 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:8:85 }))] (EpExplicitBraces (EpTok (EpaSpan { T20452.hs:8:84 })) @@ -471,14 +459,10 @@ (NoExtField) (ClassDecl ((,,) - (EpAnn - (EpaSpan { T20452.hs:9:1-85 }) - [(AddEpAnn AnnClass (EpaSpan { T20452.hs:9:1-5 })) - ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:9:78-82 })) - ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:9:84 })) - ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:9:85 }))] - (EpaComments - [])) + [(AddEpAnn AnnClass (EpaSpan { T20452.hs:9:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T20452.hs:9:78-82 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T20452.hs:9:84 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:9:85 }))] (EpExplicitBraces (EpTok (EpaSpan { T20452.hs:9:84 })) ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -43,12 +43,8 @@ (TyClD (NoExtField) (DataDecl - (EpAnn - (EpaSpan { T18791.hs:(4,1)-(5,17) }) - [(AddEpAnn AnnData (EpaSpan { T18791.hs:4:1-4 })) - ,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:4:8-12 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T18791.hs:4:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:4:8-12 }))] (L (EpAnn (EpaSpan { T18791.hs:4:6 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -622,6 +622,21 @@ annotationsToComments (EpAnn anc a cs) l kws = do | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls | otherwise = go (cs', (AddEpAnn k ss):ans) ls +annotationsToComments' :: (Monad m, Monoid w) + => a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m a +annotationsToComments' a l kws = do + let (newComments, newAnns) = go ([],[]) (view l a) + addComments newComments + return (set l (reverse newAnns) a) + where + keywords = Set.fromList kws + + go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) + go acc [] = acc + go (cs',ans) ((AddEpAnn k ss) : ls) + | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls + | otherwise = go (cs', (AddEpAnn k ss):ans) ls + -- --------------------------------------------------------------------- -- Temporary function to simply reproduce the "normal" pretty printer output @@ -818,6 +833,20 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do return (AddEpAnn kw' r') | otherwise = return (AddEpAnn kw' r) +markEpAnnLMS0 :: (Monad m, Monoid w) + => a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m a +markEpAnnLMS0 an l _kw Nothing = markLensKwA' an l +markEpAnnLMS0 a l kw (Just str) = do + anns <- go (view l a) + return (set l anns a) + where + go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn + go (AddEpAnn kw' r) + | kw' == kw = do + r' <- printStringAtAA r str + return (AddEpAnn kw' r') + | otherwise = return (AddEpAnn kw' r) + -- --------------------------------------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -860,14 +889,25 @@ markArrow (HsExplicitMult (pct, arr) t) = do markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") +markAnnCloseP' :: (Monad m, Monoid w) => AnnPragma -> EP w m AnnPragma +markAnnCloseP' an = markEpAnnLMS0 an lapr_close AnnClose (Just "#-}") + markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt) +markAnnOpenP' :: (Monad m, Monoid w) => AnnPragma -> SourceText -> String -> EP w m AnnPragma +markAnnOpenP' an NoSourceText txt = markEpAnnLMS0 an lapr_open AnnOpen (Just txt) +markAnnOpenP' an (SourceText txt) _ = markEpAnnLMS0 an lapr_open AnnOpen (Just $ unpackFS txt) + markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt) +markAnnOpen0 :: (Monad m, Monoid w) => [AddEpAnn] -> SourceText -> String -> EP w m [AddEpAnn] +markAnnOpen0 an NoSourceText txt = markEpAnnLMS'' an lidl AnnOpen (Just txt) +markAnnOpen0 an (SourceText txt) _ = markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS txt) + markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt @@ -1268,6 +1308,12 @@ markLensKwA (EpAnn anc a cs) l = do loc <- markKw (view l a) return (EpAnn anc (set l loc a) cs) +markLensKwA' :: (Monad m, Monoid w) + => a -> Lens a AddEpAnn -> EP w m a +markLensKwA' a l = do + loc <- markKw (view l a) + return (set l loc a) + markLensKw :: (Monad m, Monoid w) => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) markLensKw (EpAnn anc a cs) l kw = do @@ -1876,16 +1922,14 @@ instance ExactPrint (InstDecl GhcPs) where data DataFamInstDeclWithContext = DataFamInstDeclWithContext - { _dc_a :: EpAnn [AddEpAnn] + { _dc_a :: [AddEpAnn] , _dc_f :: TopLevelFlag , dc_d :: DataFamInstDecl GhcPs } instance ExactPrint DataFamInstDeclWithContext where - getAnnotationEntry (DataFamInstDeclWithContext _ _ (DataFamInstDecl (FamEqn { feqn_ext = an}))) - = fromAnn an - setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc ts cs - = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc ts cs)}))) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (DataFamInstDeclWithContext an c d) = do debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an (an', d') <- exactDataFamInstDecl an c d @@ -1894,8 +1938,8 @@ instance ExactPrint DataFamInstDeclWithContext where -- --------------------------------------------------------------------- exactDataFamInstDecl :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs - -> EP w m (EpAnn [AddEpAnn], DataFamInstDecl GhcPs) + => [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs + -> EP w m ([AddEpAnn], DataFamInstDecl GhcPs) exactDataFamInstDecl an top_lvl (DataFamInstDecl (FamEqn { feqn_ext = an2 , feqn_tycon = tycon @@ -1917,14 +1961,14 @@ exactDataFamInstDecl an top_lvl where pp_hdr :: (Monad m, Monoid w) => Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] + -> EP w m ( [AddEpAnn] , LocatedN RdrName , HsOuterTyVarBndrs () GhcPs , HsFamEqnPats GhcPs , Maybe (LHsContext GhcPs)) pp_hdr mctxt = do an0 <- case top_lvl of - TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel + TopLevel -> markEpAnnL' an lidl AnnInstance -- TODO: maybe in toplevel NotTopLevel -> return an exactHsFamInstLHS an0 tycon bndrs pats fixity mctxt @@ -2033,34 +2077,34 @@ instance ExactPrint CCallConv where -- --------------------------------------------------------------------- instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry (Warnings (an,_) _) = fromAnn an - setAnnotationAnchor (Warnings (an,a) b) anc ts cs = Warnings ((setAnchorEpa an anc ts cs),a) b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (Warnings (an,src) warns) = do - an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED + an0 <- markAnnOpen0 an src "{-# WARNING" -- Note: might be {-# DEPRECATED warns' <- markAnnotated warns - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") return (Warnings (an1,src) warns') -- --------------------------------------------------------------------- instance ExactPrint (WarnDecl GhcPs) where - getAnnotationEntry (Warning an _ _) = fromAnn an - setAnnotationAnchor (Warning an a b) anc ts cs = Warning (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (Warning an lns (WarningTxt mb_cat src ls )) = do mb_cat' <- markAnnotated mb_cat lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" + an0 <- markEpAnnL' an lidl AnnOpenS -- "[" ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" + an1 <- markEpAnnL' an0 lidl AnnCloseS -- "]" return (Warning an1 lns' (WarningTxt mb_cat' src ls')) exact (Warning an lns (DeprecatedTxt src ls)) = do lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" + an0 <- markEpAnnL' an lidl AnnOpenS -- "[" ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" + an1 <- markEpAnnL' an0 lidl AnnCloseS -- "]" return (Warning an1 lns' (DeprecatedTxt src ls')) -- --------------------------------------------------------------------- @@ -2172,11 +2216,12 @@ instance ExactPrint (DocDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (RoleAnnotDecl GhcPs) where - getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an - setAnnotationAnchor (RoleAnnotDecl an a b) anc ts cs = RoleAnnotDecl (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RoleAnnotDecl an ltycon roles) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnRole + an0 <- markEpAnnL' an lidl AnnType + an1 <- markEpAnnL' an0 lidl AnnRole ltycon' <- markAnnotated ltycon let markRole (L l (Just r)) = do (L _ r') <- markAnnotated (L l r) @@ -2214,8 +2259,8 @@ instance ExactPrint (RuleBndr GhcPs) where -- --------------------------------------------------------------------- instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where - getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an - setAnnotationAnchor fe anc ts cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc ts cs} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor fe _ _ _s = fe exact (FamEqn { feqn_ext = an , feqn_tycon = tycon , feqn_bndrs = bndrs @@ -2223,7 +2268,7 @@ instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where , feqn_fixity = fixity , feqn_rhs = rhs }) = do (an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS an tycon bndrs pats fixity Nothing - an1 <- markEpAnnL an0 lidl AnnEqual + an1 <- markEpAnnL' an0 lidl AnnEqual rhs' <- markAnnotated rhs return (FamEqn { feqn_ext = an1 , feqn_tycon = tycon' @@ -2236,34 +2281,34 @@ instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where exactHsFamInstLHS :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] + => [AddEpAnn] -> LocatedN RdrName -> HsOuterTyVarBndrs () GhcPs -> HsFamEqnPats GhcPs -> LexicalFixity -> Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] + -> EP w m ( [AddEpAnn] , LocatedN RdrName , HsOuterTyVarBndrs () GhcPs , HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs)) exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do - an0 <- markEpAnnL an lidl AnnForall + an0 <- markEpAnnL' an lidl AnnForall bndrs' <- markAnnotated bndrs - an1 <- markEpAnnL an0 lidl AnnDot + an1 <- markEpAnnL' an0 lidl AnnDot mb_ctxt' <- mapM markAnnotated mb_ctxt (an2, thing', typats') <- exact_pats an1 typats return (an2, thing', bndrs', typats', mb_ctxt') where exact_pats :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> HsFamEqnPats GhcPs -> EP w m (EpAnn [AddEpAnn], LocatedN RdrName, HsFamEqnPats GhcPs) + => [AddEpAnn] -> HsFamEqnPats GhcPs -> EP w m ([AddEpAnn], LocatedN RdrName, HsFamEqnPats GhcPs) exact_pats an' (patl:patr:pats) | Infix <- fixity = let exact_op_app = do - an0 <- markEpAnnAllL an' lidl AnnOpenP + an0 <- markEpAnnAllL' an' lidl AnnOpenP patl' <- markAnnotated patl thing' <- markAnnotated thing patr' <- markAnnotated patr - an1 <- markEpAnnAllL an0 lidl AnnCloseP + an1 <- markEpAnnAllL' an0 lidl AnnCloseP return (an1, thing', [patl',patr']) in case pats of [] -> exact_op_app @@ -2273,10 +2318,10 @@ exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do return (an0, thing', p++pats') exact_pats an' pats = do - an0 <- markEpAnnAllL an' lidl AnnOpenP + an0 <- markEpAnnAllL' an' lidl AnnOpenP thing' <- markAnnotated thing pats' <- markAnnotated pats - an1 <- markEpAnnAllL an0 lidl AnnCloseP + an1 <- markEpAnnAllL' an0 lidl AnnCloseP return (an1, thing', pats') -- --------------------------------------------------------------------- @@ -2293,9 +2338,8 @@ instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) -- --------------------------------------------------------------------- instance ExactPrint (ClsInstDecl GhcPs) where - getAnnotationEntry (ClsInstDecl { cid_ext = (_, an, _) }) = fromAnn an - setAnnotationAnchor (cid at ClsInstDecl { cid_ext = (mbWarn, an, sortKey) }) anc ts cs - = cid { cid_ext = (mbWarn, setAnchorEpa an anc ts cs, sortKey) } + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (ClsInstDecl { cid_ext = (mbWarn, an, sortKey) , cid_poly_ty = inst_ty, cid_binds = binds @@ -2304,15 +2348,15 @@ instance ExactPrint (ClsInstDecl GhcPs) where , cid_datafam_insts = adts }) = do (mbWarn', an0, mbOverlap', inst_ty') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL an1 lid AnnSemi + an1 <- markEpAnnL' an0 lidl AnnOpenC + an2 <- markEpAnnAllL' an1 lid AnnSemi ds <- withSortKey sortKey [(ClsAtdTag, prepareListAnnotationA ats), (ClsAtdTag, prepareListAnnotationF an adts), (ClsMethodTag, prepareListAnnotationA (bagToList binds)), (ClsSigTag, prepareListAnnotationA sigs) ] - an3 <- markEpAnnL an2 lidl AnnCloseC -- '}' + an3 <- markEpAnnL' an2 lidl AnnCloseC -- '}' let ats' = undynamic ds adts' = undynamic ds @@ -2326,11 +2370,11 @@ instance ExactPrint (ClsInstDecl GhcPs) where where top_matter = do - an0 <- markEpAnnL an lidl AnnInstance + an0 <- markEpAnnL' an lidl AnnInstance mw <- mapM markAnnotated mbWarn mo <- mapM markAnnotated mbOverlap it <- markAnnotated inst_ty - an1 <- markEpAnnL an0 lidl AnnWhere -- Optional + an1 <- markEpAnnL' an0 lidl AnnWhere -- Optional return (mw, an1, mo,it) -- --------------------------------------------------------------------- @@ -2661,7 +2705,7 @@ instance ExactPrint HsIPName where -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotationF :: (Monad m, Monoid w) => - EpAnn [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] + [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] prepareListAnnotationF an ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls where go (L l a) = do @@ -2834,26 +2878,26 @@ instance ExactPrint (DefaultDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an - setAnnotationAnchor (HsAnnotation (an,a) b c) anc ts cs = HsAnnotation ((setAnchorEpa an anc ts cs),a) b c + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (HsAnnotation (an, src) prov e) = do - an0 <- markAnnOpenP an src "{-# ANN" + an0 <- markAnnOpenP' an src "{-# ANN" (an1, prov') <- case prov of (ValueAnnProvenance n) -> do n' <- markAnnotated n return (an0, ValueAnnProvenance n') (TypeAnnProvenance n) -> do - an1 <- markEpAnnL an0 lapr_rest AnnType + an1 <- markEpAnnL' an0 lapr_rest AnnType n' <- markAnnotated n return (an1, TypeAnnProvenance n') ModuleAnnProvenance -> do - an1 <- markEpAnnL an lapr_rest AnnModule + an1 <- markEpAnnL' an lapr_rest AnnModule return (an1, prov) e' <- markAnnotated e - an2 <- markAnnCloseP an1 + an2 <- markAnnCloseP' an1 return (HsAnnotation (an2,src) prov' e') -- --------------------------------------------------------------------- @@ -3639,17 +3683,8 @@ exactTransStmt an by using GroupForm = do -- --------------------------------------------------------------------- instance ExactPrint (TyClDecl GhcPs) where - getAnnotationEntry (FamDecl { }) = NoEntryVal - getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an - getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an - getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an - - setAnnotationAnchor a at FamDecl{} _ _ _s = a - setAnnotationAnchor x at SynDecl{} anc ts cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc ts cs } - setAnnotationAnchor x at DataDecl{} anc ts cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc ts cs } - setAnnotationAnchor x at ClassDecl{} anc ts cs = x { tcdCExt = (setAnchorEpa an anc ts cs, layout, a) } - where - (an,layout,a) = tcdCExt x + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a exact (FamDecl a decl) = do decl' <- markAnnotated decl @@ -3661,11 +3696,11 @@ instance ExactPrint (TyClDecl GhcPs) where -- There may be arbitrary parens around parts of the constructor -- that are infix. Turn these into comments so that they feed -- into the right place automatically - an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP] - an1 <- markEpAnnL an0 lidl AnnType + an0 <- annotationsToComments' an lidl [AnnOpenP,AnnCloseP] + an1 <- markEpAnnL' an0 lidl AnnType (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing - an2 <- markEpAnnL an1 lidl AnnEqual + an2 <- markEpAnnL' an1 lidl AnnEqual rhs' <- markAnnotated rhs return (SynDecl { tcdSExt = an2 , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity @@ -3692,8 +3727,8 @@ instance ExactPrint (TyClDecl GhcPs) where | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part = do (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnL an1 lidl AnnCloseC + an1 <- markEpAnnL' an0 lidl AnnOpenC + an2 <- markEpAnnL' an1 lidl AnnCloseC return (ClassDecl {tcdCExt = (an2, lo, sortKey), tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', tcdFixity = fixity, @@ -3705,8 +3740,8 @@ instance ExactPrint (TyClDecl GhcPs) where | otherwise -- Laid out = do (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL an1 lidl AnnSemi + an1 <- markEpAnnL' an0 lidl AnnOpenC + an2 <- markEpAnnAllL' an1 lidl AnnSemi ds <- withSortKey sortKey [(ClsSigTag, prepareListAnnotationA sigs), (ClsMethodTag, prepareListAnnotationA (bagToList methods)), @@ -3714,7 +3749,7 @@ instance ExactPrint (TyClDecl GhcPs) where (ClsAtdTag, prepareListAnnotationA at_defs) -- ++ prepareListAnnotation docs ] - an3 <- markEpAnnL an2 lidl AnnCloseC + an3 <- markEpAnnL' an2 lidl AnnCloseC let sigs' = undynamic ds methods' = listToBag $ undynamic ds @@ -3729,16 +3764,16 @@ instance ExactPrint (TyClDecl GhcPs) where tcdDocs = _docs}) where top_matter = do - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - an0 <- markEpAnnL an' lidl AnnClass + an' <- annotationsToComments' an lidl [AnnOpenP, AnnCloseP] + an0 <- markEpAnnL' an' lidl AnnClass (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context (an1, fds') <- if (null fds) then return (an0, fds) else do - an1 <- markEpAnnL an0 lidl AnnVbar + an1 <- markEpAnnL' an0 lidl AnnVbar fds' <- markAnnotated fds return (an1, fds') - an2 <- markEpAnnL an1 lidl AnnWhere + an2 <- markEpAnnL' an1 lidl AnnWhere return (an2, fds', lclas', tyvars',context') @@ -3836,15 +3871,15 @@ exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType exactDataDefn :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] - -> (Maybe (LHsContext GhcPs) -> EP w m (EpAnn [AddEpAnn] + => [AddEpAnn] + -> (Maybe (LHsContext GhcPs) -> EP w m ([AddEpAnn] , LocatedN RdrName , a , b , Maybe (LHsContext GhcPs))) -- Printing the header -> HsDataDefn GhcPs - -> EP w m ( EpAnn [AddEpAnn] -- ^ from exactHdr - , EpAnn [AddEpAnn] -- ^ updated one passed in + -> EP w m ( [AddEpAnn] -- ^ from exactHdr + , [AddEpAnn] -- ^ updated one passed in , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs) exactDataDefn an exactHdr (HsDataDefn { dd_ext = x, dd_ctxt = context @@ -3852,36 +3887,36 @@ exactDataDefn an exactHdr , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) = do - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] + an' <- annotationsToComments' an lidl [AnnOpenP, AnnCloseP] an0 <- case condecls of DataTypeCons is_type_data _ -> do an0' <- if is_type_data - then markEpAnnL an' lidl AnnType + then markEpAnnL' an' lidl AnnType else return an' - markEpAnnL an0' lidl AnnData - NewTypeCon _ -> markEpAnnL an' lidl AnnNewtype + markEpAnnL' an0' lidl AnnData + NewTypeCon _ -> markEpAnnL' an' lidl AnnNewtype - an1 <- markEpAnnL an0 lidl AnnInstance -- optional + an1 <- markEpAnnL' an0 lidl AnnInstance -- optional mb_ct' <- mapM markAnnotated mb_ct (anx, ln', tvs', b, mctxt') <- exactHdr context (an2, mb_sig') <- case mb_sig of Nothing -> return (an1, Nothing) Just kind -> do - an2 <- markEpAnnL an1 lidl AnnDcolon + an2 <- markEpAnnL' an1 lidl AnnDcolon kind' <- markAnnotated kind return (an2, Just kind') an3 <- if (needsWhere condecls) - then markEpAnnL an2 lidl AnnWhere + then markEpAnnL' an2 lidl AnnWhere else return an2 - an4 <- markEpAnnL an3 lidl AnnOpenC + an4 <- markEpAnnL' an3 lidl AnnOpenC (an5, condecls') <- exact_condecls an4 (toList condecls) let condecls'' = case condecls of DataTypeCons d _ -> DataTypeCons d condecls' NewTypeCon _ -> case condecls' of [decl] -> NewTypeCon decl _ -> panic "exacprint NewTypeCon" - an6 <- markEpAnnL an5 lidl AnnCloseC + an6 <- markEpAnnL' an5 lidl AnnCloseC derivings' <- mapM markAnnotated derivings return (anx, an6, ln', tvs', b, mctxt', (HsDataDefn { dd_ext = x, dd_ctxt = context @@ -3895,7 +3930,7 @@ exactVanillaDeclHead :: (Monad m, Monoid w) -> LHsQTyVars GhcPs -> LexicalFixity -> Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] + -> EP w m ( [AddEpAnn] , LocatedN RdrName , LHsQTyVars GhcPs , (), Maybe (LHsContext GhcPs)) @@ -4329,7 +4364,7 @@ markTrailing ts = do -- based on pp_condecls in Decls.hs exact_condecls :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EP w m (EpAnn [AddEpAnn],[LConDecl GhcPs]) + => [AddEpAnn] -> [LConDecl GhcPs] -> EP w m ([AddEpAnn],[LConDecl GhcPs]) exact_condecls an cs | gadt_syntax -- In GADT syntax = do @@ -4337,7 +4372,7 @@ exact_condecls an cs return (an, cs') | otherwise -- In H98 syntax = do - an0 <- markEpAnnL an lidl AnnEqual + an0 <- markEpAnnL' an lidl AnnEqual cs' <- mapM markAnnotated cs return (an0, cs') where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e848e044e94eeed1fc54c32edf436cdf175ca1c1...e7fec482471f3fede91fb119ae60182fb8054408 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e848e044e94eeed1fc54c32edf436cdf175ca1c1...e7fec482471f3fede91fb119ae60182fb8054408 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 Dec 11 23:16:15 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 18:16:15 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <6577983fa053_3478bc7fb5405858966b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: fbc06264 by Matthew Craven at 2023-12-11T18:15:04-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 - - - - - b90ba829 by Matthew Craven at 2023-12-11T18:15:04-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 9151caa3 by Oleg Grenrus at 2023-12-11T18:15:04-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. - - - - - 180aeb4e by Vladislav Zavialov at 2023-12-11T18:15:04-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. - - - - - 26 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,23 +1131,29 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,38 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +125,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +154,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -666,9 +662,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -879,6 +876,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,36 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +742,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +762,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +789,93 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +901,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +914,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,33 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2440,8 +2440,8 @@ of ``-W(no-)*``. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification that would stop working under :extension:`RequiredTypeArguments`. ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -599,3 +599,4 @@ test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) test('T23719', normal, compile_fail, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f21c8b3b047e706323adb965a779fd2640cdd74...180aeb4e2c69023fae83ed337ed29de235397dba -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1f21c8b3b047e706323adb965a779fd2640cdd74...180aeb4e2c69023fae83ed337ed29de235397dba 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 Dec 12 03:45:54 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 11 Dec 2023 22:45:54 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: LinearTypes => MonoLocalBinds Message-ID: <6577d772e15aa_3478bc863ced1860869e@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 6b1335c2 by Matthew Craven at 2023-12-11T22:45:46-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 - - - - - 53a54c2f by Matthew Craven at 2023-12-11T22:45:46-05:00 Fix formatting of Note [alg-alt heap check] - - - - - a0c7713a by Oleg Grenrus at 2023-12-11T22:45:47-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. - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match.hs-boot - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/180aeb4e2c69023fae83ed337ed29de235397dba...a0c7713a0e48502a2ea86ace4d1914649d267973 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/180aeb4e2c69023fae83ed337ed29de235397dba...a0c7713a0e48502a2ea86ace4d1914649d267973 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 Dec 12 06:36:58 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 01:36:58 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <6577ff8aa1d73_3478bc89fe86006266a0@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 287cf53c by Matthew Craven at 2023-12-12T01:36:33-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 - - - - - 8d6904ff by Matthew Craven at 2023-12-12T01:36:33-05:00 Fix formatting of Note [alg-alt heap check] - - - - - 6eb6e900 by Oleg Grenrus at 2023-12-12T01:36:33-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. - - - - - 23 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,23 +1131,29 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,38 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +125,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +154,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -666,9 +662,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -879,6 +876,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,36 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +742,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +762,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +789,93 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +901,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +914,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -599,3 +599,4 @@ test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) test('T23719', normal, compile_fail, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0c7713a0e48502a2ea86ace4d1914649d267973...6eb6e900d91b1d2035b8299b562cafd6a828c060 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a0c7713a0e48502a2ea86ace4d1914649d267973...6eb6e900d91b1d2035b8299b562cafd6a828c060 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 Dec 12 09:37:21 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 04:37:21 -0500 Subject: [Git][ghc/ghc][master] 2 commits: LinearTypes => MonoLocalBinds Message-ID: <657829d0f1b37_393b781c06cf456498@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 30 changed files: - compiler/GHC/Core.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match.hs-boot - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Utils/Env.hs - + compiler/GHC/Tc/Utils/TcMType.hs-boot - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Binds.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/linear_types.rst The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/522c12a43b34ad4ca7f3f916fa630d33a4fe6efb...8e0446dfd79099403d005e04f63ea49496b1cab3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/522c12a43b34ad4ca7f3f916fa630d33a4fe6efb...8e0446dfd79099403d005e04f63ea49496b1cab3 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 Dec 12 09:38:06 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 04:38:06 -0500 Subject: [Git][ghc/ghc][master] 2 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <657829fe78081_393b781a30bc861688@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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] - - - - - 17 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr Changes: ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -921,5 +921,6 @@ instance Outputable PrimCall where primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case SeqOp -> False - DataToTagOp -> False + DataToTagSmallOp -> False + DataToTagLargeOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3689,7 +3689,27 @@ section "Tag to enum stuff" and small integers.} ------------------------------------------------------------------------ -primop DataToTagOp "dataToTagLarge#" GenPrimOp +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp a_levpoly -> Int# { Used internally to implement @dataToTag#@: Use that function instead! This one offers /no advantage/ and comes with no stability ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1131,23 +1131,29 @@ checkTypeDataConOcc what dc (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) {- --- | Check that a use of dataToTagLarge# satisfies condition DTT2 --- from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class -- --- Ignores applications not headed by dataToTagLarge#. +-- Ignores applications not headed by dataToTag# primops. -- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. checkDataToTagPrimOpTyCon :: CoreExpr -- ^ the function (head of the application) we are checking -> [CoreArg] -- ^ The arguments to the application -> LintM () checkDataToTagPrimOpTyCon (Var fun_id) args - | Just DataToTagOp <- isPrimOpId_maybe fun_id + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp = case args of Type _levity : Type dty : _rest | Just (tc, _) <- splitTyConApp_maybe dty , isValidDTT2TyCon tc - -> pure () + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" <+> ppr dty _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -102,7 +102,8 @@ That is why these rules are built in here. primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -1985,7 +1986,9 @@ tagToEnumRule = do ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [DataToTag overview] in GHC.Tc.Instance.Class. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x @@ -3374,7 +3377,8 @@ caseRules platform (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp = case splitTyConApp_maybe ty of Just (tc, _) | isValidDTT2TyCon tc -> Just (v, tx_con_dtt tc @@ -3382,9 +3386,9 @@ caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x _ -> pprTraceUserWarning warnMsg Nothing where warnMsg = vcat $ map text - [ "Found dataToTag primop applied to a non-ADT type. This" - , "could be a future bug in GHC, or it may be caused by an" - , "unsupported use of the ghc-internal primop dataToTagLarge#." + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." , "In either case, the GHC developers would like to know about it!" , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" ] @@ -3554,7 +3558,7 @@ Note [caseRules for dataToTag] See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTagLarge# x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3569,12 +3573,17 @@ case-flattening and case-of-known-constructor and can be very important for code using derived Eq instances. We can apply this transformation only when we can easily get the -constructors from the type at which dataToTagLarge# is used. And we +constructors from the type at which dataToTagSmall# is used. And we cannot apply this transformation at "type data"-related types without breaking invariant I1 from Note [Type data declarations] in GHC.Rename.Module. That leaves exactly the types satisfying condition DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Take care if we see something like ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -495,10 +495,9 @@ occurrence of `x` and `y` to record whether it is evaluated and properly tagged. For the vast majority of primops that's a waste of time: the argument is an `Int#` or something. -But code generation for `seq#` and `dataToTagLarge#` /does/ consult that -tag, to statically avoid generating an eval: -* `seq#`: uses `getCallMethod` on its first argument, which looks at the `tagSig` -* `dataToTagLarge#`: checks `tagSig` directly in the `DataToTagOp` case of `cgExpr`. +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. So for these we should call `rewriteArgs`. @@ -507,7 +506,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == SeqOp || primOp == DataToTagSmallOp || primOp == DataToTagLargeOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -73,55 +73,51 @@ cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] +-- dataToTagSmall# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + -- dataToTagLarge# :: a_levpoly -> Int# --- See Note [DataToTag overview] in GHC.Tc.Instance.Class --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform emitComment (mkFastString "dataToTagLarge#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. - - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) - - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) + + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) + + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -666,9 +662,10 @@ isSimpleScrut _ _ = return False isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTagLarge# evaluates its argument; +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; -- see Note [DataToTag overview] in GHC.Tc.Instance.Class -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -879,6 +876,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1640,7 +1640,8 @@ emitPrimOp cfg primop = SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal - DataToTagOp -> alwaysExternal + DataToTagSmallOp -> alwaysExternal + DataToTagLargeOp -> alwaysExternal MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -967,7 +967,11 @@ genPrim prof bound ty op = case op of ------------------------------ Tag to enum stuff -------------------------------- - DataToTagOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= var "h$dataToTag_e" + , returnS (app "h$e" [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat [ stack .! PreInc sp |= var "h$dataToTag_e" , returnS (app "h$e" [d]) ] ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -50,6 +50,8 @@ import GHC.Core.Class import GHC.Core ( Expr(..) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) @@ -671,15 +673,17 @@ But, to avoid all this boilerplate code, and improve optimisation opportunities, GHC generates instances like this: instance DataToTag [a] where - dataToTag# = dataToTagLarge# + dataToTag# = dataToTagSmall# -using a (temporarily strangely-named) primop `dataToTagLarge#`. The -primop has the following over-polymorphic type +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# -Every call to (dataToTagLarge# @{lev} @ty) that we generate should -satisfy these conditions: +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: (DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. This is an invariant--we must satisfy this or Core Lint will complain. @@ -698,25 +702,36 @@ satisfy these conditions: GHC.Rename.Module. See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold for why this matters. - While the dataToTagLarge# primop remains exposed from GHC.Prim - (and abused in GHC.PrimopWrappers), this cannot be a true invariant. - But with a little effort we can ensure that every `dataToTagLarge#` + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop call we generate in a DataToTag instance satisfies this condition. -The `dataToTagLarge#` primop has special handling in several parts of +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of the compiler: -- It has a couple of built-in rewrite rules, implemented in - GHC.Core.Opt.ConstantFold.dataToTagRule +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule -- The simplifier rewrites most case expressions scrutinizing its result. - See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. -- It evaluates its argument; this is implemented via a special case in - GHC.StgToCmm.Expr.cgExpr. +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, -- Additionally, a special case in GHC.Stg.InferTags.Rewrite.rewriteExpr ensures - that that any inferred tag information on the argument is retained until then. + * We have a special case in GHC.Stg.InferTags.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) Wrinkles: @@ -727,12 +742,12 @@ Wrinkles: [W] DataToTag (D (Either t1 t2)) GHC uses the built-in instance instance DataToTag (D (Either p q)) where - dataToTag# x = dataToTagLarge# @Lifted @(R:DEither p q) + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) (x |> sym (ax:DEither p q)) where `ax:DEither` is the axiom arising from the `data instance`: ax:DEither p q :: D (Either p q) ~ R:DEither p q - Notice that we cast `x` before giving it to `dataToTagLarge#`, so + Notice that we cast `x` before giving it to `dataToTagSmall#`, so that (DTT2) is satisfied. (DTW2) Suppose we have module A (T(..)) where { data T = TCon } @@ -747,7 +762,7 @@ Wrinkles: (DTW3) Similar to DTW2, consider this example: {-# LANGUAGE MagicHash #-} - module A (X(X2, X3), f) where + module A (X(X2, X3), g) where -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs import GHC.Exts (dataToTag#, Int#) data X = X1 | X2 | X3 | X4 @@ -774,23 +789,93 @@ Wrinkles: keepAlive on the constructor names. (Contrast with Note [Unused name reporting and HasField].) -(DTW4) It is expected that in the future some instances may select more - efficient specialised implementations; for example we may use a - separate `dataToTagSmall#` primop for a type with only a few - constructors; see #17079 and #21710. - -(DTW5) We make no promises about the primops used to implement +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough contructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement DataToTag instances. Changes to GHC's representation of algebraic data types at runtime may force us to redesign these primops. Indeed, accommodating such changes without breaking users of the original (no longer existing) "dataToTag#" primop is one of the main reasons the DataToTag class exists! - We can currently get away with using the same primop for every - DataToTag instance because every Haskell-land data constructor use - gets translated to its own "real" heap or static data object at - runtime and the index of that constructor is always exposed via - pointer tagging and via the object's info table. + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + Historical note: @@ -816,6 +901,7 @@ matchDataToTag :: Class -> [Type] -> TcM ClsInstResult matchDataToTag dataToTagClass [levity, dty] = do famEnvs <- tcGetFamInstEnvs (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform if | isConcreteType levity -- condition C3 , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty , let (repTyCon, repArgs, repCo) @@ -828,13 +914,14 @@ matchDataToTag dataToTagClass [levity, dty] = do , let rdr_env = tcg_rdr_env gbl_env inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con , all inScope constrs -- condition C2 + , let repTy = mkTyConApp repTyCon repArgs - whichOp - -- TODO: More optimized implementations for: - -- * small constructor families - -- * Bool/Int/Float/etc. on JS backend + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp | otherwise - = primOpId DataToTagOp + = primOpId DataToTagLargeOp -- See wrinkle DTW1; we must apply the underlying -- operation at the representation type and cast it ===================================== libraries/base/src/GHC/Base.hs ===================================== @@ -117,8 +117,8 @@ import GHC.Classes import GHC.CString import GHC.Magic import GHC.Magic.Dict -import GHC.Prim hiding (dataToTagLarge#) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding (dataToTagSmall#, dataToTagLarge#) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -133,8 +133,8 @@ module GHC.Exts maxTupleSize, ) where -import GHC.Prim hiding ( coerce, dataToTagLarge# ) - -- Hide dataToTagLarge# because it is expected to break for +import GHC.Prim hiding ( coerce, dataToTagSmall#, dataToTagLarge# ) + -- Hide dataToTag# ops because they are expected to break for -- GHC-internal reasons in the near future, and shouldn't -- be exposed from base (not even GHC.Exts) ===================================== testsuite/tests/codeGen/should_compile/T21710a.stderr ===================================== @@ -1,117 +1,44 @@ -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'E2_bytes" { - M.$tc'E2_bytes: - I8[] "'E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'D2_bytes" { - M.$tc'D2_bytes: - I8[] "'D" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'C2_bytes" { - M.$tc'C2_bytes: - I8[] "'C" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'B2_bytes" { - M.$tc'B2_bytes: - I8[] "'B" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tc'A3_bytes" { - M.$tc'A3_bytes: - I8[] "'A" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$tcE2_bytes" { - M.$tcE2_bytes: - I8[] "E" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule2_bytes" { - M.$trModule2_bytes: - I8[] "M" - }] - - - -==================== Output Cmm ==================== -[section ""cstring" . M.$trModule4_bytes" { - M.$trModule4_bytes: - I8[] "main" - }] - - - ==================== Output Cmm ==================== [M.foo_entry() { // [R2] - { info_tbls: [(cBa, - label: block_cBa_info + { info_tbls: [(cCU, + label: block_cCU_info rep: StackRep [] srt: Nothing), - (cBi, + (cD2, label: M.foo_info rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cBi: // global - if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch - cBj: // global + cD2: // global + if ((Sp + -8) < SpLim) (likely: False) goto cD3; else goto cD4; // CmmCondBranch + cD3: // global R1 = M.foo_closure; // CmmAssign call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall - cBk: // global - I64[Sp - 8] = cBa; // CmmStore + cD4: // global + I64[Sp - 8] = cCU; // CmmStore R1 = R2; // CmmAssign Sp = Sp - 8; // CmmAssign - if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch - cBb: // global - call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall - cBa: // global - _cBh::P64 = R1 & 7; // CmmAssign - if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch - uBz: // global - if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch - cBe: // global - // dataToTag# - _cBn::P64 = R1 & 7; // CmmAssign - if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch - cBs: // global - _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign - goto cBq; // CmmBranch - cBr: // global - _cBo::I64 = _cBn::P64 - 1; // CmmAssign - goto cBq; // CmmBranch - cBq: // global - R1 = _cBo::I64; // CmmAssign + if (R1 & 7 != 0) goto cCU; else goto cCV; // CmmCondBranch + cCV: // global + call (I64[R1])(R1) returns to cCU, args: 8, res: 8, upd: 8; // CmmCall + cCU: // global + _cD1::P64 = R1 & 7; // CmmAssign + if (_cD1::P64 != 1) goto uDf; else goto cCZ; // CmmCondBranch + uDf: // global + if (_cD1::P64 != 2) goto cCY; else goto cD0; // CmmCondBranch + cCY: // global + // dataToTagSmall# + R1 = R1 & 7 - 1; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBg: // global + cD0: // global R1 = 42; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall - cBf: // global + cCZ: // global R1 = 2; // CmmAssign Sp = Sp + 8; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall @@ -124,190 +51,6 @@ -==================== Output Cmm ==================== -[section ""data" . M.$trModule3_closure" { - M.$trModule3_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule4_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule1_closure" { - M.$trModule1_closure: - const GHC.Types.TrNameS_con_info; - const M.$trModule2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$trModule_closure" { - M.$trModule_closure: - const GHC.Types.Module_con_info; - const M.$trModule3_closure+1; - const M.$trModule1_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE1_closure" { - M.$tcE1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tcE2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tcE_closure" { - M.$tcE_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tcE1_closure+1; - const GHC.Types.krep$*_closure+5; - const 10475418246443540865; - const 12461417314693222409; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A1_closure" { - M.$tc'A1_closure: - const GHC.Types.KindRepTyConApp_con_info; - const M.$tcE_closure+1; - const GHC.Types.[]_closure+1; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A2_closure" { - M.$tc'A2_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'A3_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'A_closure" { - M.$tc'A_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'A2_closure+1; - const M.$tc'A1_closure+1; - const 10991425535368257265; - const 3459663971500179679; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B1_closure" { - M.$tc'B1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'B2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'B_closure" { - M.$tc'B_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'B1_closure+1; - const M.$tc'A1_closure+1; - const 13038863156169552918; - const 13430333535161531545; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C1_closure" { - M.$tc'C1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'C2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'C_closure" { - M.$tc'C_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'C1_closure+1; - const M.$tc'A1_closure+1; - const 8482817676735632621; - const 8146597712321241387; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D1_closure" { - M.$tc'D1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'D2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'D_closure" { - M.$tc'D_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'D1_closure+1; - const M.$tc'A1_closure+1; - const 7525207739284160575; - const 13746130127476219356; - const 0; - const 3; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E1_closure" { - M.$tc'E1_closure: - const GHC.Types.TrNameS_con_info; - const M.$tc'E2_bytes; - }] - - - -==================== Output Cmm ==================== -[section ""data" . M.$tc'E_closure" { - M.$tc'E_closure: - const GHC.Types.TyCon_con_info; - const M.$trModule_closure+1; - const M.$tc'E1_closure+1; - const M.$tc'A1_closure+1; - const 6748545530683684316; - const 10193016702094081137; - const 0; - const 3; - }] - - - ==================== Output Cmm ==================== [section ""data" . M.A_closure" { M.A_closure: @@ -362,14 +105,14 @@ ==================== Output Cmm ==================== [M.A_con_entry() { // [] - { info_tbls: [(cC5, + { info_tbls: [(cDt, label: M.A_con_info rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cC5: // global + cDt: // global R1 = R1 + 1; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -379,14 +122,14 @@ ==================== Output Cmm ==================== [M.B_con_entry() { // [] - { info_tbls: [(cCa, + { info_tbls: [(cDy, label: M.B_con_info rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCa: // global + cDy: // global R1 = R1 + 2; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -396,14 +139,14 @@ ==================== Output Cmm ==================== [M.C_con_entry() { // [] - { info_tbls: [(cCf, + { info_tbls: [(cDD, label: M.C_con_info rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCf: // global + cDD: // global R1 = R1 + 3; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -413,14 +156,14 @@ ==================== Output Cmm ==================== [M.D_con_entry() { // [] - { info_tbls: [(cCk, + { info_tbls: [(cDI, label: M.D_con_info rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCk: // global + cDI: // global R1 = R1 + 4; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } @@ -430,14 +173,14 @@ ==================== Output Cmm ==================== [M.E_con_entry() { // [] - { info_tbls: [(cCp, + { info_tbls: [(cDN, label: M.E_con_info rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} } srt: Nothing)] stack_info: arg_space: 8 } {offset - cCp: // global + cDN: // global R1 = R1 + 5; // CmmAssign call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall } ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -1,41 +1,40 @@ -ref compiler/GHC/Core/Coercion/Axiom.hs:463:2: Note [RoughMap and rm_empty] -ref compiler/GHC/Core/Opt/OccurAnal.hs:983:7: Note [Loop breaking] -ref compiler/GHC/Core/Opt/SetLevels.hs:1574:30: Note [Top level scope] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2826:13: Note [Case binder next] -ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4018:8: Note [Lambda-bound unfoldings] -ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] -ref compiler/GHC/Core/Opt/Specialise.hs:1765:29: Note [Arity decrease] -ref compiler/GHC/Core/TyCo/Rep.hs:1565:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1245:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1738:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1774:7: Note [Pending Splices] -ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] -ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] -ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] -ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] -ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] -ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] +ref compiler/GHC/Core/Coercion/Axiom.hs:472:2: Note [RoughMap and rm_empty] +ref compiler/GHC/Core/Opt/OccurAnal.hs:1157:7: Note [Loop breaking] +ref compiler/GHC/Core/Opt/SetLevels.hs:1586:30: Note [Top level scope] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2832:13: Note [Case binder next] +ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4023:8: Note [Lambda-bound unfoldings] +ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1342:37: Note [Gentle mode] +ref compiler/GHC/Core/Opt/Specialise.hs:1763:29: Note [Arity decrease] +ref compiler/GHC/Core/TyCo/Rep.hs:1652:31: Note [What prevents a constraint from floating] +ref compiler/GHC/Driver/DynFlags.hs:1251:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/Main.hs:1749:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1727:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1763:7: Note [Pending Splices] +ref compiler/GHC/Hs/Extension.hs:147:5: Note [Strict argument type constraints] +ref compiler/GHC/Hs/Pat.hs:141:74: Note [Lifecycle of a splice] +ref compiler/GHC/HsToCore/Pmc/Solver.hs:856:20: Note [COMPLETE sets on data families] +ref compiler/GHC/HsToCore/Quote.hs:1487:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Stg/Unarise.hs:438:32: Note [Renaming during unarisation] +ref compiler/GHC/StgToCmm/Expr.hs:578:4: Note [case on bool] ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] -ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] -ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] -ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:356:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:531:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:655:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:888:11: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Solver/Rewrite.hs:1009:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1130:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types/Constraint.hs:226:34: Note [NonCanonical Semantics] -ref compiler/GHC/Types/Demand.hs:302:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] +ref compiler/GHC/Tc/Gen/HsType.hs:2676:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/Pat.hs:174:20: Note [Typing patterns in pattern bindings] +ref compiler/GHC/Tc/Gen/Pat.hs:1163:7: Note [Matching polytyped patterns] +ref compiler/GHC/Tc/Gen/Sig.hs:80:10: Note [Overview of type signatures] +ref compiler/GHC/Tc/Gen/Splice.hs:358:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:533:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:657:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Instance/Family.hs:406:35: Note [Constrained family instances] +ref compiler/GHC/Tc/Solver/Rewrite.hs:1010:7: Note [Stability of rewriting] +ref compiler/GHC/Tc/TyCl.hs:1316:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types/Constraint.hs:206:38: Note [NonCanonical Semantics] +ref compiler/GHC/Types/Demand.hs:301:25: Note [Preserving Boxity of results is rarely a win] +ref compiler/GHC/Unit/Module/Deps.hs:83:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] +ref configure.ac:203:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ===================================== testsuite/tests/simplCore/should_compile/T22375.hs ===================================== @@ -1,12 +1,19 @@ module T22375 where -data X = A | B | C | D | E +data X + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 76, types: 41, coercions: 0, joins: 0/0} + = {terms: 96, types: 41, coercions: 0, joins: 0/0} -- RHS size: {terms: 14, types: 9, coercions: 0, joins: 0/0} T22375.$fEqX_$c== :: X -> X -> Bool @@ -50,22 +50,27 @@ T22375.$fEqX [InlPrag=CONLIKE] :: Eq X T22375.$fEqX = GHC.Classes.C:Eq @X T22375.$fEqX_$c== T22375.$fEqX_$c/= --- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 44, types: 3, coercions: 0, joins: 0/0} T22375.$wf [InlPrag=[2]] :: X -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], Arity=2, Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375.$wf = \ (x :: X) (ww :: GHC.Prim.Int#) -> case x of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.hs ===================================== @@ -6,13 +6,20 @@ import Data.Kind type X :: Type -> Type data family X a -data instance X () = A | B | C | D | E +data instance X () + = A | B | C | D | E + | F | G | H | I | J deriving Eq f :: X () -> Int -> Int f x v - | x == A = 1 + v - | x == B = 2 + v - | x == C = 3 + v - | x == D = 4 + v - | otherwise = 5 + v + | x == A = v + 1 + | x == B = v + 2 + | x == C = v + 3 + | x == D = v + 4 + | x == E = v + 5 + | x == F = v + 6 + | x == G = v + 7 + | x == H = v + 8 + | x == I = v + 9 + | otherwise = v + 10 ===================================== testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 86, types: 65, coercions: 15, joins: 0/0} + = {terms: 116, types: 75, coercions: 25, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} T22375DataFamily.$WA [InlPrag=INLINE[final] CONLIKE] :: X () @@ -58,6 +58,61 @@ T22375DataFamily.$WE `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) :: T22375DataFamily.R:XUnit ~R# X ()) +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WF [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WF + = T22375DataFamily.F + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WG [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WG + = T22375DataFamily.G + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WH [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WH + = T22375DataFamily.H + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WI [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WI + = T22375DataFamily.I + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + +-- RHS size: {terms: 1, types: 0, coercions: 2, joins: 0/0} +T22375DataFamily.$WJ [InlPrag=INLINE[final] CONLIKE] :: X () +[GblId[DataConWrapper], + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)}] +T22375DataFamily.$WJ + = T22375DataFamily.J + `cast` (Sym (T22375DataFamily.D:R:XUnit0[0]) + :: T22375DataFamily.R:XUnit ~R# X ()) + -- RHS size: {terms: 14, types: 11, coercions: 2, joins: 0/0} T22375DataFamily.$fEqX_$c== :: X () -> X () -> Bool [GblId, @@ -133,7 +188,7 @@ T22375DataFamily.$fEqX = GHC.Classes.C:Eq @(X ()) T22375DataFamily.$fEqX_$c== T22375DataFamily.$fEqX_$c/= --- RHS size: {terms: 24, types: 4, coercions: 1, joins: 0/0} +-- RHS size: {terms: 44, types: 4, coercions: 1, joins: 0/0} T22375DataFamily.$wf [InlPrag=[2]] :: X () -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId[StrictWorker([!])], @@ -141,18 +196,23 @@ T22375DataFamily.$wf [InlPrag=[2]] Str=<1L>, Unf=Unf{Src=, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, - Guidance=IF_ARGS [64 0] 55 0}] + Guidance=IF_ARGS [119 0] 110 0}] T22375DataFamily.$wf = \ (x :: X ()) (ww :: GHC.Prim.Int#) -> case x `cast` (T22375DataFamily.D:R:XUnit0[0] :: X () ~R# T22375DataFamily.R:XUnit) of { - A -> GHC.Prim.+# 1# ww; - B -> GHC.Prim.+# 2# ww; - C -> GHC.Prim.+# 3# ww; - D -> GHC.Prim.+# 4# ww; - E -> GHC.Prim.+# 5# ww + A -> GHC.Prim.+# ww 1#; + B -> GHC.Prim.+# ww 2#; + C -> GHC.Prim.+# ww 3#; + D -> GHC.Prim.+# ww 4#; + E -> GHC.Prim.+# ww 5#; + F -> GHC.Prim.+# ww 6#; + G -> GHC.Prim.+# ww 7#; + H -> GHC.Prim.+# ww 8#; + I -> GHC.Prim.+# ww 9#; + J -> GHC.Prim.+# ww 10# } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e0446dfd79099403d005e04f63ea49496b1cab3...35c7aef6aa3d735c86defab4db083b4c0c37b92e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8e0446dfd79099403d005e04f63ea49496b1cab3...35c7aef6aa3d735c86defab4db083b4c0c37b92e 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 Dec 12 09:38:45 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 04:38:45 -0500 Subject: [Git][ghc/ghc][master] Allow untyped brackets in typed splices and vice versa. Message-ID: <65782a252a104_393b781c0a46c65030@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 6 changed files: - compiler/GHC/Rename/Splice.hs - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr - testsuite/tests/th/all.T Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -85,6 +85,38 @@ checkForTemplateHaskellQuotes e = unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body = addErrCtxt (typedQuotationCtxtDoc br_body) $ @@ -93,9 +125,8 @@ rnTypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -123,9 +154,8 @@ rnUntypedBracket e br_body -- Check for nested brackets ; cur_stage <- getStage ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + { Splice _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" ===================================== testsuite/tests/th/T24190.hs ===================================== @@ -0,0 +1,11 @@ +module Main (main) where + +import Language.Haskell.TH + +main :: IO () +main = do + -- type annotations are needed so the monad is not ambiguous. + -- we also highlight that the monad can be different: + -- brackets are "just" syntax. + print $$(const [|| 'x' ||] ([| 'y' |] :: IO Exp)) + print $( const [| 'x' |] ([|| 'y' ||] :: Code IO Char)) ===================================== testsuite/tests/th/T24190.stdout ===================================== @@ -0,0 +1,2 @@ +'x' +'x' ===================================== testsuite/tests/th/TH_NestedSplicesFail3.stderr ===================================== @@ -1,5 +1,8 @@ -TH_NestedSplicesFail3.hs:4:12: error: [GHC-45108] - • Untyped brackets may not appear in typed splices. - • In the Template Haskell quotation [| 'x' |] - In the typed splice: $$([| 'x' |]) +TH_NestedSplicesFail3.hs:4:12: error: [GHC-39999] + • No instance for ‘Language.Haskell.TH.Syntax.Quote + (Language.Haskell.TH.Syntax.Code Language.Haskell.TH.Syntax.Q)’ + arising from a quotation bracket + • In the expression: [| 'x' |] + In the Template Haskell splice $$([| 'x' |]) + In the expression: $$([| 'x' |]) ===================================== testsuite/tests/th/TH_NestedSplicesFail4.stderr ===================================== @@ -1,5 +1,9 @@ -TH_NestedSplicesFail4.hs:4:11: error: [GHC-45108] - • Typed brackets may not appear in untyped splices. - • In the Template Haskell typed quotation [|| 'y' ||] +TH_NestedSplicesFail4.hs:4:11: error: [GHC-83865] + • Couldn't match type: Language.Haskell.TH.Syntax.Code m0 Char + with: Language.Haskell.TH.Syntax.Q Language.Haskell.TH.Syntax.Exp + Expected: Language.Haskell.TH.Lib.Internal.ExpQ + Actual: Language.Haskell.TH.Syntax.Code m0 Char + • In the Template Haskell quotation [|| 'y' ||] + In the expression: [|| 'y' ||] In the untyped splice: $([|| 'y' ||]) ===================================== testsuite/tests/th/all.T ===================================== @@ -599,3 +599,4 @@ test('T23971', normal, compile_and_run, ['']) test('T23986', normal, compile_and_run, ['']) test('T24111', normal, compile_and_run, ['']) test('T23719', normal, compile_fail, ['']) +test('T24190', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7397c7849763489cdba514cc9ad3f199947e443e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7397c7849763489cdba514cc9ad3f199947e443e 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 Dec 12 09:43:47 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 12 Dec 2023 04:43:47 -0500 Subject: [Git][ghc/ghc][wip/int-index/rta-docs] 16 commits: Take care when simplifying unfoldings Message-ID: <65782b538829c_393b781c0a46c66920@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/rta-docs at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1f170604 by Vladislav Zavialov at 2023-12-12T12:40:25+03: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. - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match.hs-boot - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3316b7be5ee0d23f3da3edc3d9f446e7be560dd5...1f17060405d8dcf03f6db1b75341b70472b42f53 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3316b7be5ee0d23f3da3edc3d9f446e7be560dd5...1f17060405d8dcf03f6db1b75341b70472b42f53 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 Dec 12 14:10:01 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 09:10:01 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Introduce `dataToTagSmall#` primop (closes #21710) Message-ID: <657869b9d61e3_393b788da7e941038b7@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - a2809b00 by Ben Gamari at 2023-12-12T09:09:55-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. - - - - - 6baecbd8 by Ben Gamari at 2023-12-12T09:09:55-05:00 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. - - - - - a07aff91 by Ben Gamari at 2023-12-12T09:09:55-05:00 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. - - - - - 04ed43be by Moritz Angermann at 2023-12-12T09:09:56-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. - - - - - a169d5b6 by Vladislav Zavialov at 2023-12-12T09:09:57-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. - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Instance/Class.hs - configure.ac - distrib/configure.ac.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - − m4/xcode_version.m4 - rts/eventlog/EventLog.c - rts/include/Stg.h - testsuite/tests/codeGen/should_compile/T21710a.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/simplCore/should_compile/T22375.hs - testsuite/tests/simplCore/should_compile/T22375.stderr - testsuite/tests/simplCore/should_compile/T22375DataFamily.hs - testsuite/tests/simplCore/should_compile/T22375DataFamily.stderr - + testsuite/tests/th/T24190.hs - + testsuite/tests/th/T24190.stdout - testsuite/tests/th/TH_NestedSplicesFail3.stderr - testsuite/tests/th/TH_NestedSplicesFail4.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6eb6e900d91b1d2035b8299b562cafd6a828c060...a169d5b6f3ae54ae384da1879e5dca39083d22e8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6eb6e900d91b1d2035b8299b562cafd6a828c060...a169d5b6f3ae54ae384da1879e5dca39083d22e8 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 Dec 12 14:14:22 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 12 Dec 2023 09:14:22 -0500 Subject: [Git][ghc/ghc][wip/T24197] 143 commits: Explicitly require RLIMIT_AS before use in OSMem.c Message-ID: <65786abe630e3_393b788d6c9ac11446f@gitlab.mail> Zubin pushed to branch wip/T24197 at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - e9b8116b by Ben Gamari at 2023-12-12T14:14:07+00: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. - - - - - ceef3896 by Ben Gamari at 2023-12-12T14:14:07+00:00 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. - - - - - 6c79030c by Ben Gamari at 2023-12-12T14:14:07+00:00 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. - - - - - 30 changed files: - .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/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/FamInstEnv.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51c0f61763d09a7092759f24d746dd2fdadc6b5f...6c79030c1232eeeaebc35742288c00186c9d1575 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51c0f61763d09a7092759f24d746dd2fdadc6b5f...6c79030c1232eeeaebc35742288c00186c9d1575 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 Dec 12 16:40:35 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 11:40:35 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Drop hard Xcode dependency Message-ID: <65788d02dc155_393b78bf9de6c160064@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: cf49168b by Moritz Angermann at 2023-12-12T11:40:28-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. - - - - - 3ed7a7e9 by Vladislav Zavialov at 2023-12-12T11:40:28-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. - - - - - 6 changed files: - configure.ac - distrib/configure.ac.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - − m4/xcode_version.m4 Changes: ===================================== configure.ac ===================================== @@ -342,9 +342,6 @@ then GMP_FORCE_INTREE="YES" fi -XCODE_VERSION() - - dnl ** Building a cross compiler? dnl -------------------------------------------------------------- CrossCompiling=NO ===================================== distrib/configure.ac.in ===================================== @@ -94,8 +94,6 @@ then AC_MSG_ERROR([find is required.]) fi -XCODE_VERSION() - AC_ARG_ENABLE(distro-toolchain, [AS_HELP_STRING([--enable-distro-toolchain], [Do not use bundled Windows toolchain binaries.])], ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,34 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. - With :extension:`LinearTypes`, ``let`` and ``where`` bindings can now be linear. So the following now typechecks:: @@ -28,7 +45,6 @@ Language where y = f x - - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not enabled. That is, GHC would erroneously accept the following code: :: ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2440,8 +2440,8 @@ of ``-W(no-)*``. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification that would stop working under :extension:`RequiredTypeArguments`. ===================================== m4/xcode_version.m4 deleted ===================================== @@ -1,25 +0,0 @@ -# XCODE_VERSION() -# -------------------------------- -# Gets the version number of Xcode, if on a Mac -AC_DEFUN([XCODE_VERSION],[ - if test "$TargetVendor_CPP" = "apple" - then - AC_MSG_CHECKING(Xcode version) - XcodeVersion=`(xcode-select -p > /dev/null 2>&1 && xcodebuild -version) | grep Xcode | sed "s/Xcode //"` - # Old Xcode versions don't actually give the Xcode version - if test "$XcodeVersion" = "" - then - AC_MSG_RESULT(not found (too old?)) - XcodeVersion1=0 - XcodeVersion2=0 - else - AC_MSG_RESULT($XcodeVersion) - XcodeVersion1=`echo "$XcodeVersion" | sed 's/\..*//'` - changequote(, )dnl - XcodeVersion2=`echo "$XcodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` - changequote([, ])dnl - AC_MSG_NOTICE(Xcode version component 1: $XcodeVersion1) - AC_MSG_NOTICE(Xcode version component 2: $XcodeVersion2) - fi - fi -]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a169d5b6f3ae54ae384da1879e5dca39083d22e8...3ed7a7e9556d12c18d870f1f6574edb4eb9fab0e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a169d5b6f3ae54ae384da1879e5dca39083d22e8...3ed7a7e9556d12c18d870f1f6574edb4eb9fab0e 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 Dec 12 18:11:50 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 12 Dec 2023 13:11:50 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/int-index/ep-token-only Message-ID: <6578a266be71d_393b78e99c81c179031@gitlab.mail> Vladislav Zavialov pushed new branch wip/int-index/ep-token-only at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/ep-token-only 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 Dec 12 18:23:05 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Tue, 12 Dec 2023 13:23:05 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T23405-copy Message-ID: <6578a508f2eda_393b78f01c20018444a@gitlab.mail> Zubin pushed new branch wip/T23405-copy at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23405-copy 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 Dec 12 18:35:40 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Tue, 12 Dec 2023 13:35:40 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove EpAnn from SigD extension points Message-ID: <6578a7fcbb1c9_393b78f33bc9c1937b9@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: cb2c2387 by Alan Zimmerman at 2023-12-12T18:35:03+00:00 EPA: Remove EpAnn from SigD extension points - - - - - 13 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Transform.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -114,7 +114,7 @@ type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish]) -- type Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. -type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] +type instance XPatBind GhcPs (GhcPass pR) = [AddEpAnn] type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] type instance XPatBind GhcTc (GhcPass pR) = ( Type -- Type of the GRHSs @@ -671,16 +671,16 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ************************************************************************ -} -type instance XTypeSig (GhcPass p) = EpAnn AnnSig -type instance XPatSynSig (GhcPass p) = EpAnn AnnSig -type instance XClassOpSig (GhcPass p) = EpAnn AnnSig -type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSpecInstSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XMinimalSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XSCCFunSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) +type instance XTypeSig (GhcPass p) = AnnSig +type instance XPatSynSig (GhcPass p) = AnnSig +type instance XClassOpSig (GhcPass p) = AnnSig +type instance XFixSig (GhcPass p) = [AddEpAnn] +type instance XInlineSig (GhcPass p) = [AddEpAnn] +type instance XSpecSig (GhcPass p) = [AddEpAnn] +type instance XSpecInstSig (GhcPass p) = ([AddEpAnn], SourceText) +type instance XMinimalSig (GhcPass p) = ([AddEpAnn], SourceText) +type instance XSCCFunSig (GhcPass p) = ([AddEpAnn], SourceText) +type instance XCompleteMatchSig (GhcPass p) = ([AddEpAnn], SourceText) -- SourceText: Note [Pragma source text] in "GHC.Types.SourceText" type instance XXSig GhcPs = DataConCantHappen type instance XXSig GhcRn = IdSig ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -656,7 +656,7 @@ instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where ppr (DctSingle _ ty) = ppr ty ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn] +type instance XStandaloneKindSig GhcPs = [AddEpAnn] type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -1003,13 +1003,13 @@ type instance XCDerivDecl GhcPs = ( Maybe (LWarningTxt GhcPs) -- The warning of the deprecated derivation -- See Note [Implementation of deprecated instances] -- in GHC.Tc.Solver.Dict - , EpAnn [AddEpAnn] ) + , [AddEpAnn] ) type instance XCDerivDecl GhcRn = ( Maybe (LWarningTxt GhcRn) -- The warning of the deprecated derivation -- See Note [Implementation of deprecated instances] -- in GHC.Tc.Solver.Dict - , EpAnn [AddEpAnn] ) -type instance XCDerivDecl GhcTc = EpAnn [AddEpAnn] + , [AddEpAnn] ) +type instance XCDerivDecl GhcTc = [AddEpAnn] type instance XXDerivDecl (GhcPass _) = DataConCantHappen derivDeprecation :: forall p. IsPass p @@ -1190,13 +1190,13 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XCRuleDecls GhcPs = ([AddEpAnn], SourceText) type instance XCRuleDecls GhcRn = SourceText type instance XCRuleDecls GhcTc = SourceText type instance XXRuleDecls (GhcPass _) = DataConCantHappen -type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText) +type instance XHsRule GhcPs = (HsRuleAnn, SourceText) type instance XHsRule GhcRn = (HsRuleRn, SourceText) type instance XHsRule GhcTc = (HsRuleRn, SourceText) ===================================== compiler/GHC/Parser.y ===================================== @@ -1259,7 +1259,7 @@ topdecl :: { LHsDecl GhcPs } | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glEE $1 $>) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) } | '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getDEPRECATED_PRAGs $1)) (fromOL $2))) } | '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getWARNING_PRAGs $1)) (fromOL $2))) } - | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) } + | '{-# RULES' rules '#-}' {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ([mo $1,mc $3], (getRULES_PRAGs $1)) (reverse $2))) } | annotation { $1 } | decl_no_th { $1 } @@ -1626,8 +1626,8 @@ stand_alone_deriving :: { LDerivDecl GhcPs } : 'deriving' deriv_standalone_strategy 'instance' maybe_warning_pragma overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $6) } - ; acsA (\cs -> sLL $1 $> - (DerivDecl ($4, EpAnn (glEE $1 $>) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $6) $2 $5)) }} + ; amsA' (sLL $1 $> + (DerivDecl ($4, [mj AnnDeriving $1, mj AnnInstance $3]) (mkHsWildCardBndrs $6) $2 $5)) }} ----------------------------------------------------------------------------- -- Role annotations @@ -1696,8 +1696,8 @@ where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype - {% acsA (\cs -> sLL $1 $> - $ PatSynSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs) + {% amsA' (sLL $1 $> + $ PatSynSig (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) (toList $ unLoc $2) $4) } qvarcon :: { LocatedN RdrName } @@ -1719,7 +1719,7 @@ decl_cls : at_decl_cls { $1 } do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) - ; acsA (\cs -> sLL $1 $> $ SigD noExtField $ ClassOpSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }} + ; amsA' (sLL $1 $> $ SigD noExtField $ ClassOpSig (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) True [v] $4) }} decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) @@ -1879,12 +1879,12 @@ rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp {%runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> - acsA (\cs -> (sLL $1 $> $ HsRule - { rd_ext = (EpAnn (glEE $1 $>) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1) + amsA' (sLL $1 $> $ HsRule + { rd_ext = (((fstOf3 $3) (mj AnnEqual $5 : (fst $2))), getSTRINGs $1) , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 - , rd_lhs = $4, rd_rhs = $6 })) } + , rd_lhs = $4, rd_rhs = $6 }) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas rule_activation :: { ([AddEpAnn],Maybe Activation) } @@ -2609,14 +2609,14 @@ sigdecl :: { LHsDecl GhcPs } infixexp '::' sigtype {% do { $1 <- runPV (unECP $1) ; v <- checkValSigLhs $1 - ; acsA (\cs -> (sLL $1 $> $ SigD noExtField $ - TypeSig (EpAnn (glEE $1 $>) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} } + ; amsA' (sLL $1 $> $ SigD noExtField $ + TypeSig (AnnSig (mu AnnDcolon $2) []) [v] (mkHsWildCardBndrs $3))} } | var ',' sig_vars '::' sigtype {% do { v <- addTrailingCommaN $1 (gl $2) - ; let sig cs = TypeSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3)) + ; let sig = TypeSig (AnnSig (mu AnnDcolon $4) []) (v : reverse (unLoc $3)) (mkHsWildCardBndrs $5) - ; acsA (\cs -> sLL $1 $> $ SigD noExtField (sig cs) ) }} + ; amsA' (sLL $1 $> $ SigD noExtField sig ) }} | infix prec ops {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3 @@ -2627,8 +2627,8 @@ sigdecl :: { LHsDecl GhcPs } -- it defaults to maxPrecedence Nothing -> (NoSourceText, maxPrecedence) Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) - ; acsA (\cs -> sLL $1 $> $ SigD noExtField - (FixSig (EpAnn (glEE $1 $>) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3) + ; amsA' (sLL $1 $> $ SigD noExtField + (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn) (FixitySig noExtField (fromOL $ unLoc $3) (Fixity fixText fixPrec (unLoc $1))))) }} @@ -2636,44 +2636,42 @@ sigdecl :: { LHsDecl GhcPs } | '{-# COMPLETE' qcon_list opt_tyconsig '#-}' {% let (dcolon, tc) = $3 - in acsA - (\cs -> sLL $1 $> - (SigD noExtField (CompleteMatchSig ((EpAnn (glEE $1 $>) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) } + in amsA' (sLL $1 $> + (SigD noExtField (CompleteMatchSig ([ mo $1 ] ++ dcolon ++ [mc $4], (getCOMPLETE_PRAGs $1)) $2 tc))) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvarcon '#-}' - {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glEE $1 $>) ((mo $1:fst $2) ++ [mc $4]) cs) $3 + {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig ((mo $1:fst $2) ++ [mc $4]) $3 (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) - (snd $2))))) } + (snd $2)))) } | '{-# OPAQUE' qvar '#-}' - {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glEE $1 $>) [mo $1, mc $3] cs) $2 - (mkOpaquePragma (getOPAQUE_PRAGs $1))))) } + {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig [mo $1, mc $3] $2 + (mkOpaquePragma (getOPAQUE_PRAGs $1)))) } | '{-# SCC' qvar '#-}' - {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glEE $1 $>) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) } + {% amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ([mo $1, mc $3], (getSCC_PRAGs $1)) $2 Nothing))) } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing - ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glEE $1 $>) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }} + ; amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ([mo $1, mc $4], (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }} | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' - {% acsA (\cs -> + {% amsA' ( let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) (NoUserInlinePrag, FunLike) (snd $2) - in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) } + in sLL $1 $> $ SigD noExtField (SpecSig (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) $3 (fromOL $5) inl_prag)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) + {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) $3 (fromOL $5) (mkInlinePragma (getSPEC_INLINE_PRAGs $1) (getSPEC_INLINE $1) (snd $2)))) } | '{-# SPECIALISE' 'instance' inst_type '#-}' - {% acsA (\cs -> sLL $1 $> - $ SigD noExtField (SpecInstSig ((EpAnn (glEE $1 $>) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) } + {% amsA' (sLL $1 $> $ SigD noExtField (SpecInstSig ([mo $1,mj AnnInstance $2,mc $4], (getSPEC_PRAGs $1)) $3)) } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glEE $1 $>) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) } + {% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ([mo $1,mc $3], (getMINIMAL_PRAGs $1)) $2)) } activation :: { ([AddEpAnn],Maybe Activation) } -- See Note [%shift: activation -> {- empty -}] ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -276,9 +276,8 @@ mkStandaloneKindSig mkStandaloneKindSig loc lhs rhs anns = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) - ; cs <- getCommentsFor loc ; return $ L (noAnnSrcSpan loc) - $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs } + $ StandaloneKindSig anns v rhs } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) @@ -1366,9 +1365,8 @@ checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v)))) , m_pats = [] , m_grhss = grhss } -checkPatBind loc annsIn lhs (L _ grhss) = do - cs <- getCommentsFor loc - return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss) +checkPatBind _loc annsIn lhs (L _ grhss) = do + return (PatBind annsIn lhs grhss) checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -91,13 +91,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544.hs:6:3-16 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:6:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:6:6-7 })) + []) (False) [(L (EpAnn @@ -254,13 +250,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544.hs:10:3-16 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:10:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:10:6-7 })) + []) (False) [(L (EpAnn @@ -415,13 +407,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544.hs:14:3-16 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:14:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:14:6-7 })) + []) (False) [(L (EpAnn @@ -579,13 +567,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544.hs:18:3-16 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:18:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:18:6-7 })) + []) (False) [(L (EpAnn @@ -666,13 +650,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544.hs:20:3-16 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:20:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:20:6-7 })) + []) (False) [(L (EpAnn ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -332,13 +332,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { T17544_kw.hs:24:5-18 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:24:15-16 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:24:15-16 })) + []) (False) [(L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -193,12 +193,8 @@ (KindSigD (NoExtField) (StandaloneKindSig - (EpAnn - (EpaSpan { DumpParsedAst.hs:9:1-27 }) - [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:9:1-4 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:9:13-14 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:9:1-4 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:9:13-14 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:9:6-11 }) @@ -827,12 +823,8 @@ (KindSigD (NoExtField) (StandaloneKindSig - (EpAnn - (EpaSpan { DumpParsedAst.hs:17:1-35 }) - [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:17:1-4 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:9-10 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:17:1-4 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:9-10 }))] (L (EpAnn (EpaSpan { DumpParsedAst.hs:17:6-7 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -151,13 +151,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { DumpSemis.hs:9:1-12 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:9:5-6 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:9:5-6 })) + []) [(L (EpAnn (EpaSpan { DumpSemis.hs:9:1-3 }) @@ -448,13 +444,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { DumpSemis.hs:14:1-12 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:14:5-6 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:14:5-6 })) + []) [(L (EpAnn (EpaSpan { DumpSemis.hs:14:1-3 }) @@ -708,13 +700,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { DumpSemis.hs:21:1-12 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:21:5-6 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:21:5-6 })) + []) [(L (EpAnn (EpaSpan { DumpSemis.hs:21:1-3 }) @@ -1359,13 +1347,9 @@ (EpaComments [])) (ClassOpSig - (EpAnn - (EpaSpan { DumpSemis.hs:29:3-23 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:29:9-10 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:29:9-10 })) + []) (False) [(L (EpAnn @@ -1453,13 +1437,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { DumpSemis.hs:31:1-30 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:31:3-4 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { DumpSemis.hs:31:3-4 })) + []) [(L (EpAnn (EpaSpan { DumpSemis.hs:31:1 }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -714,13 +714,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { KindSigs.hs:22:1-44 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:5-6 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:5-6 })) + []) [(L (EpAnn (EpaSpan { KindSigs.hs:22:1-3 }) @@ -1480,13 +1476,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { KindSigs.hs:34:1-22 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:6-7 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:6-7 })) + []) [(L (EpAnn (EpaSpan { KindSigs.hs:34:1-4 }) ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -43,11 +43,7 @@ (SigD (NoExtField) (FixSig - (EpAnn - (EpaSpan { T20846.hs:3:1-11 }) - [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))] - (EpaComments - [])) + [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))] (FixitySig (NoExtField) [(L ===================================== testsuite/tests/parser/should_compile/T23315/T23315.stderr ===================================== @@ -61,13 +61,9 @@ (SigD (NoExtField) (TypeSig - (EpAnn - (EpaSpan { T23315.hsig:3:1-7 }) - (AnnSig - (AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 })) - []) - (EpaComments - [])) + (AnnSig + (AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 })) + []) [(L (EpAnn (EpaSpan { T23315.hsig:3:1 }) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -776,6 +776,11 @@ markLensAA (EpAnn anc a cs) l = do a' <- markKw (view l a) return (EpAnn anc (set l a' a) cs) +markLensAA' :: (Monad m, Monoid w) => a -> Lens a AddEpAnn -> EP w m a +markLensAA' a l = do + a' <- markKw (view l a) + return (set l a' a) + markEpAnnLMS :: (Monad m, Monoid w) => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) @@ -900,13 +905,9 @@ markAnnOpenP' :: (Monad m, Monoid w) => AnnPragma -> SourceText -> String -> EP markAnnOpenP' an NoSourceText txt = markEpAnnLMS0 an lapr_open AnnOpen (Just txt) markAnnOpenP' an (SourceText txt) _ = markEpAnnLMS0 an lapr_open AnnOpen (Just $ unpackFS txt) -markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) -markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt) - -markAnnOpen0 :: (Monad m, Monoid w) => [AddEpAnn] -> SourceText -> String -> EP w m [AddEpAnn] -markAnnOpen0 an NoSourceText txt = markEpAnnLMS'' an lidl AnnOpen (Just txt) -markAnnOpen0 an (SourceText txt) _ = markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS txt) +markAnnOpen :: (Monad m, Monoid w) => [AddEpAnn] -> SourceText -> String -> EP w m [AddEpAnn] +markAnnOpen an NoSourceText txt = markEpAnnLMS'' an lidl AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS txt) markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) @@ -1987,13 +1988,13 @@ rendering the DataDefn are contained in the FamEqn, and are called -- --------------------------------------------------------------------- instance ExactPrint (DerivDecl GhcPs) where - getAnnotationEntry (DerivDecl {deriv_ext = (_, an)} ) = fromAnn an - setAnnotationAnchor (dd at DerivDecl {deriv_ext = (w, an)}) anc ts cs - = dd { deriv_ext = (w, setAnchorEpa an anc ts cs) } + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (DerivDecl (mw, an) typ ms mov) = do - an0 <- markEpAnnL an lidl AnnDeriving + an0 <- markEpAnnL' an lidl AnnDeriving ms' <- mapM markAnnotated ms - an1 <- markEpAnnL an0 lidl AnnInstance + an1 <- markEpAnnL' an0 lidl AnnInstance mw' <- mapM markAnnotated mw mov' <- mapM markAnnotated mov typ' <- markAnnotated typ @@ -2081,7 +2082,7 @@ instance ExactPrint (WarnDecls GhcPs) where setAnnotationAnchor a _ _ _ = a exact (Warnings (an,src) warns) = do - an0 <- markAnnOpen0 an src "{-# WARNING" -- Note: might be {-# DEPRECATED + an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED warns' <- markAnnotated warns an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") return (Warnings (an1,src) warns') @@ -2131,66 +2132,63 @@ instance ExactPrint FastString where -- --------------------------------------------------------------------- instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry (HsRules (an,_) _) = fromAnn an - setAnnotationAnchor (HsRules (an,a) b) anc ts cs = HsRules ((setAnchorEpa an anc ts cs),a) b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (HsRules (an, src) rules) = do an0 <- case src of - NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt) + NoSourceText -> markEpAnnLMS'' an lidl AnnOpen (Just "{-# RULES") + SourceText srcTxt -> markEpAnnLMS'' an lidl AnnOpen (Just $ unpackFS srcTxt) rules' <- markAnnotated rules - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") return (HsRules (an1,src) rules') -- --------------------------------------------------------------------- instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an - setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc ts cs - = r { rd_ext = (setAnchorEpa an anc ts cs, a)} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do - debugM "HsRule entered" (L ln' _) <- markAnnotated (L ln (nsrc, n)) - debugM "HsRule after ln" an0 <- markActivation an lra_rest act - debugM "HsRule after act" (an1, mtybndrs') <- case mtybndrs of Nothing -> return (an0, Nothing) Just bndrs -> do - an1 <- markLensMAA an0 lra_tyanns_fst -- AnnForall + an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall bndrs' <- mapM markAnnotated bndrs - an2 <- markLensMAA an1 lra_tyanns_snd -- AnnDot + an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot return (an2, Just bndrs') - an2 <- markLensMAA an1 lra_tmanns_fst -- AnnForall + an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall termbndrs' <- mapM markAnnotated termbndrs - an3 <- markLensMAA an2 lra_tmanns_snd -- AnnDot + an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot lhs' <- markAnnotated lhs - an4 <- markEpAnnL an3 lra_rest AnnEqual + an4 <- markEpAnnL' an3 lra_rest AnnEqual rhs' <- markAnnotated rhs return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') markActivation :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a) + => a -> Lens a [AddEpAnn] -> Activation -> EP w m a markActivation an l act = do case act of ActiveBefore src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnLMS an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an3 <- markEpAnnL an2 l AnnCloseS -- ']' + an0 <- markEpAnnL' an l AnnOpenS -- '[' + an1 <- markEpAnnL' an0 l AnnTilde -- ~ + an2 <- markEpAnnLMS'' an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + an3 <- markEpAnnL' an2 l AnnCloseS -- ']' return an3 ActiveAfter src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnLMS an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an2 <- markEpAnnL an1 l AnnCloseS -- ']' + an0 <- markEpAnnL' an l AnnOpenS -- '[' + an1 <- markEpAnnLMS'' an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + an2 <- markEpAnnL' an1 l AnnCloseS -- ']' return an2 NeverActive -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnL an1 l AnnCloseS -- ']' + an0 <- markEpAnnL' an l AnnOpenS -- '[' + an1 <- markEpAnnL' an0 l AnnTilde -- ~ + an2 <- markEpAnnL' an1 l AnnCloseS -- ']' return an2 _ -> return an @@ -2429,12 +2427,7 @@ instance ExactPrint (LocatedP OverlapMode) where -- --------------------------------------------------------------------- instance ExactPrint (HsBind GhcPs) where - getAnnotationEntry FunBind{} = NoEntryVal - getAnnotationEntry PatBind{pat_ext=an} = fromAnn an - getAnnotationEntry VarBind{} = NoEntryVal - getAnnotationEntry PatSynBind{} = NoEntryVal - - setAnnotationAnchor pb at PatBind{} anc ts cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc ts cs} + getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a exact (FunBind x fid matches) = do @@ -2734,42 +2727,23 @@ orderByFst (a,_) (b,_) = compare a b -- --------------------------------------------------------------------- instance ExactPrint (Sig GhcPs) where - getAnnotationEntry (TypeSig a _ _) = fromAnn a - getAnnotationEntry (PatSynSig a _ _) = fromAnn a - getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a - getAnnotationEntry (FixSig a _) = fromAnn a - getAnnotationEntry (InlineSig a _ _) = fromAnn a - getAnnotationEntry (SpecSig a _ _ _) = fromAnn a - getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a - getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a - getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a - getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a - - setAnnotationAnchor (TypeSig a x y) anc ts cs = (TypeSig (setAnchorEpa a anc ts cs) x y) - setAnnotationAnchor (PatSynSig a x y) anc ts cs = (PatSynSig (setAnchorEpa a anc ts cs) x y) - setAnnotationAnchor (ClassOpSig a x y z) anc ts cs = (ClassOpSig (setAnchorEpa a anc ts cs) x y z) - setAnnotationAnchor (FixSig a x) anc ts cs = (FixSig (setAnchorEpa a anc ts cs) x) - setAnnotationAnchor (InlineSig a x y) anc ts cs = (InlineSig (setAnchorEpa a anc ts cs) x y) - setAnnotationAnchor (SpecSig a x y z) anc ts cs = (SpecSig (setAnchorEpa a anc ts cs) x y z) - setAnnotationAnchor (SpecInstSig (a,x) y) anc ts cs = (SpecInstSig ((setAnchorEpa a anc ts cs),x) y) - setAnnotationAnchor (MinimalSig (a,x) y) anc ts cs = (MinimalSig ((setAnchorEpa a anc ts cs),x) y) - setAnnotationAnchor (SCCFunSig (a,x) y z) anc ts cs = (SCCFunSig ((setAnchorEpa a anc ts cs),x) y z) - setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc ts cs = (CompleteMatchSig ((setAnchorEpa a anc ts cs),x) y z) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (TypeSig an vars ty) = do (an', vars', ty') <- exactVarSig an vars ty return (TypeSig an' vars' ty') exact (PatSynSig an lns typ) = do - an0 <- markEpAnnL an lasRest AnnPattern + an0 <- markEpAnnL' an lasRest AnnPattern lns' <- markAnnotated lns - an1 <- markLensAA an0 lasDcolon + an1 <- markLensAA' an0 lasDcolon typ' <- markAnnotated typ return (PatSynSig an1 lns' typ') exact (ClassOpSig an is_deflt vars ty) | is_deflt = do - an0 <- markEpAnnL an lasRest AnnDefault + an0 <- markEpAnnL' an lasRest AnnDefault (an1, vars',ty') <- exactVarSig an0 vars ty return (ClassOpSig an1 is_deflt vars' ty') | otherwise = do @@ -2781,8 +2755,8 @@ instance ExactPrint (Sig GhcPs) where InfixL -> "infixl" InfixR -> "infixr" InfixN -> "infix" - an0 <- markEpAnnLMS an lidl AnnInfix (Just fixstr) - an1 <- markEpAnnLMS an0 lidl AnnVal (Just (sourceTextToString src (show v))) + an0 <- markEpAnnLMS'' an lidl AnnInfix (Just fixstr) + an1 <- markEpAnnLMS'' an0 lidl AnnVal (Just (sourceTextToString src (show v))) names' <- markAnnotated names return (FixSig an1 (FixitySig x names' (Fixity src v fdir))) @@ -2790,40 +2764,36 @@ instance ExactPrint (Sig GhcPs) where an0 <- markAnnOpen an (inl_src inl) "{-# INLINE" an1 <- markActivation an0 id (inl_act inl) ln' <- markAnnotated ln - debugM $ "InlineSig:an=" ++ showAst an - p <- getPosP - debugM $ "InlineSig: p=" ++ show p - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - debugM $ "InlineSig:done" + an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") return (InlineSig an2 ln' inl) exact (SpecSig an ln typs inl) = do an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE an1 <- markActivation an0 lidl (inl_act inl) ln' <- markAnnotated ln - an2 <- markEpAnnL an1 lidl AnnDcolon + an2 <- markEpAnnL' an1 lidl AnnDcolon typs' <- markAnnotated typs - an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}") + an3 <- markEpAnnLMS'' an2 lidl AnnClose (Just "#-}") return (SpecSig an3 ln' typs' inl) exact (SpecInstSig (an,src) typ) = do an0 <- markAnnOpen an src "{-# SPECIALISE" - an1 <- markEpAnnL an0 lidl AnnInstance + an1 <- markEpAnnL' an0 lidl AnnInstance typ' <- markAnnotated typ - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") + an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") return (SpecInstSig (an2,src) typ') exact (MinimalSig (an,src) formula) = do an0 <- markAnnOpen an src "{-# MINIMAL" formula' <- markAnnotated formula - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") return (MinimalSig (an1,src) formula') exact (SCCFunSig (an,src) ln ml) = do an0 <- markAnnOpen an src "{-# SCC" ln' <- markAnnotated ln ml' <- markAnnotated ml - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") + an1 <- markEpAnnLMS'' an0 lidl AnnClose (Just "#-}") return (SCCFunSig (an1,src) ln' ml') exact (CompleteMatchSig (an,src) cs mty) = do @@ -2833,32 +2803,32 @@ instance ExactPrint (Sig GhcPs) where case mty of Nothing -> return (an0, mty) Just ty -> do - an1 <- markEpAnnL an0 lidl AnnDcolon + an1 <- markEpAnnL' an0 lidl AnnDcolon ty' <- markAnnotated ty return (an1, Just ty') - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") + an2 <- markEpAnnLMS'' an1 lidl AnnClose (Just "#-}") return (CompleteMatchSig (an2,src) cs' mty') -- --------------------------------------------------------------------- exactVarSig :: (Monad m, Monoid w, ExactPrint a) - => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EP w m (EpAnn AnnSig, [LocatedN RdrName], a) + => AnnSig -> [LocatedN RdrName] -> a -> EP w m (AnnSig, [LocatedN RdrName], a) exactVarSig an vars ty = do vars' <- mapM markAnnotated vars - an0 <- markLensAA an lasDcolon + an0 <- markLensAA' an lasDcolon ty' <- markAnnotated ty return (an0, vars', ty') -- --------------------------------------------------------------------- instance ExactPrint (StandaloneKindSig GhcPs) where - getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an - setAnnotationAnchor (StandaloneKindSig an a b) anc ts cs = StandaloneKindSig (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (StandaloneKindSig an vars sig) = do - an0 <- markEpAnnL an lidl AnnType + an0 <- markEpAnnL' an lidl AnnType vars' <- markAnnotated vars - an1 <- markEpAnnL an0 lidl AnnDcolon + an1 <- markEpAnnL' an0 lidl AnnDcolon sig' <- markAnnotated sig return (StandaloneKindSig an1 vars' sig') ===================================== utils/check-exact/Transform.hs ===================================== @@ -210,8 +210,8 @@ captureLineSpacing ds = map (\(_,_,x) -> x) $ go (map to ds) -- --------------------------------------------------------------------- captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty)))) - = (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty')))) +captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig dc rs') ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (AnnSig dc' rs') ns (HsWC xw ty')))) where -- we want DPs for the distance from the end of the ns to the -- AnnDColon, and to the start of the ty View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb2c2387f04b95df859f31721ca0173b6c1db1b0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb2c2387f04b95df859f31721ca0173b6c1db1b0 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 Dec 12 18:49:29 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 12 Dec 2023 13:49:29 -0500 Subject: [Git][ghc/ghc][wip/int-index/ep-token-only] Remove redundant Data.Functor import Message-ID: <6578ab395a0af_393b78f67ba881943e9@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/ep-token-only at Glasgow Haskell Compiler / GHC Commits: b159f729 by Vladislav Zavialov at 2023-12-12T21:49:09+03:00 Remove redundant Data.Functor import - - - - - 1 changed file: - compiler/Language/Haskell/Syntax/Binds.hs Changes: ===================================== compiler/Language/Haskell/Syntax/Binds.hs ===================================== @@ -42,7 +42,6 @@ import GHC.Types.SourceText (StringLiteral) import Data.Void import Data.Bool import Data.Maybe -import Data.Functor {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b159f72979cb3a58e98c539531ea0e69a1f28ad4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b159f72979cb3a58e98c539531ea0e69a1f28ad4 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 Dec 12 18:53:01 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 12 Dec 2023 13:53:01 -0500 Subject: [Git][ghc/ghc][wip/int-index/ep-token-only] Fix pattern match in Parser/PostProcess Message-ID: <6578ac0de14f1_393b78f6a61701947b8@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/ep-token-only at Glasgow Haskell Compiler / GHC Commits: 2b058d37 by Vladislav Zavialov at 2023-12-12T21:52:52+03:00 Fix pattern match in Parser/PostProcess - - - - - 1 changed file: - compiler/GHC/Parser/PostProcess.hs Changes: ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1382,7 +1382,7 @@ checkPatBind :: SrcSpan -> HsMultAnn GhcPs -> P (HsBind GhcPs) checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v)))) - (L _match_span grhss) (HsNoMultAnn noExtField) + (L _match_span grhss) (HsNoMultAnn _) = return (makeFunBind v (L (noAnnSrcSpan loc) [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)])) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b058d3722969810a0e4186937f877181c06386d -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b058d3722969810a0e4186937f877181c06386d 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 Dec 12 22:00:59 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 17:00:59 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Drop hard Xcode dependency Message-ID: <6578d81bb0074_393b781471f8542128e2@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2551c2d6 by Moritz Angermann at 2023-12-12T17:00:52-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. - - - - - c9e17a97 by Vladislav Zavialov at 2023-12-12T17:00:52-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. - - - - - 6 changed files: - configure.ac - distrib/configure.ac.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst - − m4/xcode_version.m4 Changes: ===================================== configure.ac ===================================== @@ -342,9 +342,6 @@ then GMP_FORCE_INTREE="YES" fi -XCODE_VERSION() - - dnl ** Building a cross compiler? dnl -------------------------------------------------------------- CrossCompiling=NO ===================================== distrib/configure.ac.in ===================================== @@ -94,8 +94,6 @@ then AC_MSG_ERROR([find is required.]) fi -XCODE_VERSION() - AC_ARG_ENABLE(distro-toolchain, [AS_HELP_STRING([--enable-distro-toolchain], [Do not use bundled Windows toolchain binaries.])], ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,34 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. - With :extension:`LinearTypes`, ``let`` and ``where`` bindings can now be linear. So the following now typechecks:: @@ -28,7 +45,6 @@ Language where y = f x - - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not enabled. That is, GHC would erroneously accept the following code: :: ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2440,8 +2440,8 @@ of ``-W(no-)*``. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification that would stop working under :extension:`RequiredTypeArguments`. ===================================== m4/xcode_version.m4 deleted ===================================== @@ -1,25 +0,0 @@ -# XCODE_VERSION() -# -------------------------------- -# Gets the version number of Xcode, if on a Mac -AC_DEFUN([XCODE_VERSION],[ - if test "$TargetVendor_CPP" = "apple" - then - AC_MSG_CHECKING(Xcode version) - XcodeVersion=`(xcode-select -p > /dev/null 2>&1 && xcodebuild -version) | grep Xcode | sed "s/Xcode //"` - # Old Xcode versions don't actually give the Xcode version - if test "$XcodeVersion" = "" - then - AC_MSG_RESULT(not found (too old?)) - XcodeVersion1=0 - XcodeVersion2=0 - else - AC_MSG_RESULT($XcodeVersion) - XcodeVersion1=`echo "$XcodeVersion" | sed 's/\..*//'` - changequote(, )dnl - XcodeVersion2=`echo "$XcodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` - changequote([, ])dnl - AC_MSG_NOTICE(Xcode version component 1: $XcodeVersion1) - AC_MSG_NOTICE(Xcode version component 2: $XcodeVersion2) - fi - fi -]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ed7a7e9556d12c18d870f1f6574edb4eb9fab0e...c9e17a97351fe824109cabdce67986b3fe0065f9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ed7a7e9556d12c18d870f1f6574edb4eb9fab0e...c9e17a97351fe824109cabdce67986b3fe0065f9 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 Dec 12 22:10:24 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Tue, 12 Dec 2023 17:10:24 -0500 Subject: [Git][ghc/ghc][wip/int-index/ep-token-only] EPA: Move tokens into GhcPs extension fields (#23447) Message-ID: <6578da50e1f27_393b78148c6f7c220392@gitlab.mail> Vladislav Zavialov pushed to branch wip/int-index/ep-token-only at Glasgow Haskell Compiler / GHC Commits: 1d52d642 by Vladislav Zavialov at 2023-12-13T01:09:58+03: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> - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d52d6421d7e5b7acf9509bdb9ccfd08da784f52 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d52d6421d7e5b7acf9509bdb9ccfd08da784f52 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 Dec 13 00:02:45 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Tue, 12 Dec 2023 19:02:45 -0500 Subject: [Git][ghc/ghc][wip/TagToEnum-class] 60 commits: Add name for -Wdeprecated-type-abstractions (#24154) Message-ID: <6578f4a54a5e8_393b78173c5afc2295fa@gitlab.mail> Matthew Craven pushed to branch wip/TagToEnum-class at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - d13fb02f by Matthew Craven at 2023-12-12T17:54:10-05:00 WIP: Implement specially-solved TagToEnum class - - - - - c5cfde73 by Matthew Craven at 2023-12-12T17:54:46-05:00 Move dataToTag# lint stuff into checkSpecialPrimOpTypeArgs (It remains commented out.) - - - - - ead57c6a by Matthew Craven at 2023-12-12T19:01:08-05:00 Remove old tagToEnum# typechecker errors - - - - - 30 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Ids.hs - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/Lexer.x - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86c334108ac85797927c611eb6cf8884c9e21115...ead57c6ab2ac4fdcc581bcd9ee5426cc3a055a25 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86c334108ac85797927c611eb6cf8884c9e21115...ead57c6ab2ac4fdcc581bcd9ee5426cc3a055a25 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 Dec 13 00:51:25 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 19:51:25 -0500 Subject: [Git][ghc/ghc][master] Drop hard Xcode dependency Message-ID: <6579000d75f72_393b78187327842365e4@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 3 changed files: - configure.ac - distrib/configure.ac.in - − m4/xcode_version.m4 Changes: ===================================== configure.ac ===================================== @@ -342,9 +342,6 @@ then GMP_FORCE_INTREE="YES" fi -XCODE_VERSION() - - dnl ** Building a cross compiler? dnl -------------------------------------------------------------- CrossCompiling=NO ===================================== distrib/configure.ac.in ===================================== @@ -94,8 +94,6 @@ then AC_MSG_ERROR([find is required.]) fi -XCODE_VERSION() - AC_ARG_ENABLE(distro-toolchain, [AS_HELP_STRING([--enable-distro-toolchain], [Do not use bundled Windows toolchain binaries.])], ===================================== m4/xcode_version.m4 deleted ===================================== @@ -1,25 +0,0 @@ -# XCODE_VERSION() -# -------------------------------- -# Gets the version number of Xcode, if on a Mac -AC_DEFUN([XCODE_VERSION],[ - if test "$TargetVendor_CPP" = "apple" - then - AC_MSG_CHECKING(Xcode version) - XcodeVersion=`(xcode-select -p > /dev/null 2>&1 && xcodebuild -version) | grep Xcode | sed "s/Xcode //"` - # Old Xcode versions don't actually give the Xcode version - if test "$XcodeVersion" = "" - then - AC_MSG_RESULT(not found (too old?)) - XcodeVersion1=0 - XcodeVersion2=0 - else - AC_MSG_RESULT($XcodeVersion) - XcodeVersion1=`echo "$XcodeVersion" | sed 's/\..*//'` - changequote(, )dnl - XcodeVersion2=`echo "$XcodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` - changequote([, ])dnl - AC_MSG_NOTICE(Xcode version component 1: $XcodeVersion1) - AC_MSG_NOTICE(Xcode version component 2: $XcodeVersion2) - fi - fi -]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ee3b99e6889fd68da75c6ea7a14d101f71da56 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3ee3b99e6889fd68da75c6ea7a14d101f71da56 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 Dec 13 00:51:59 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 19:51:59 -0500 Subject: [Git][ghc/ghc][master] docs: update information on RequiredTypeArguments Message-ID: <6579002f9793c_393b7818be09ac24024c@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 3 changed files: - docs/users_guide/9.10.1-notes.rst - docs/users_guide/exts/required_type_arguments.rst - docs/users_guide/using-warnings.rst Changes: ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -6,17 +6,34 @@ Version 9.10.1 Language ~~~~~~~~ -- Part 1 of GHC Proposal `#281 - `_ - "Visible forall in types of terms" has been implemented. +- GHC Proposal `#281 `_ + "Visible forall in types of terms" has been partially implemented. The following code is now accepted by GHC:: - idv :: forall a -> a -> a - idv (type a) (x :: a) = x + {-# LANGUAGE RequiredTypeArguments #-} - x = idv (type Int) 42 + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + + The use of ``forall a ->`` instead of ``forall a.`` indicates a *required* type + argument. A required type argument is visually indistinguishable from a value + argument but does not exist at runtime. + + This feature is guarded behind :extension:`RequiredTypeArguments`. + +- The :extension:`ExplicitNamespaces` extension can now be used in conjunction + with :extension:`RequiredTypeArguments` to select the type namespace in a + required type argument:: + + data T = T -- the name `T` is ambiguous + f :: forall a -> ... -- `f` expects a required type argument + + x1 = f T -- refers to the /data/ constructor `T` + x2 = f (type T) -- refers to the /type/ constructor `T` - This feature is guarded behind :extension:`RequiredTypeArguments` and :extension:`ExplicitNamespaces`. - With :extension:`LinearTypes`, ``let`` and ``where`` bindings can now be linear. So the following now typechecks:: @@ -28,7 +45,6 @@ Language where y = f x - - Due to an oversight, previous GHC releases (starting from 9.4) allowed the use of promoted data types in kinds, even when :extension:`DataKinds` was not enabled. That is, GHC would erroneously accept the following code: :: ===================================== docs/users_guide/exts/required_type_arguments.rst ===================================== @@ -19,42 +19,94 @@ dependent quantification in types of terms:: id :: forall a. a -> a -- invisible dependent quantification id_vdq :: forall a -> a -> a -- visible dependent quantification -Note that the arrow in ``forall a ->`` is part of the syntax and not a function -arrow, just like the dot in ``forall a.`` is not a type operator. The essence of -a ``forall`` is the same regardless of whether it is followed by a dot or an -arrow: it introduces a type variable. But the way we bind and specify this type -variable at the term level differs. +The arrow in ``forall a ->`` is part of the syntax and not a function arrow, +just like the dot in ``forall a.`` is not a type operator. -When we define ``id``, we can use a lambda to bind a variable that stands for -the function argument:: +The choice between ``forall a.`` and ``forall a ->`` does not have any effect on +program execution. Both quantifiers introduce type variables, which are erased +during compilation. Rather, the main difference is in the syntax used at call +sites:: - -- For reference: id :: forall a. a -> a - id = \x -> x + x1 = id True -- invisible forall, the type argument is inferred by GHC + x2 = id @Bool True -- invisible forall, the type argument is supplied by the programmer -At the same time, there is no mention of ``a`` in this definition at all. It is -bound by the compiler behind the scenes, and that is why we call the ordinary -``forall a.`` an *invisible* quantifier. Compare that to ``forall a ->``, which -is considered *visible*:: + x3 = id_vdq _ True -- visible forall, the type argument is inferred by GHC + x4 = id_vdq Bool True -- visible forall, the type argument is supplied by the programmer - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) x -> x +.. _dependent-quantifier: -This time we have two binders in the lambda: -* ``type t``, corresponding to ``forall a ->`` in the signature -* ``x``, corresponding to ``a ->`` in the signature +Terminology: Dependent quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are said to be "dependent" because the +result type depends on the supplied type argument: :: + + id @Integer :: Integer -> Integer + id @String :: String -> String + + id_vdq Integer :: Integer -> Integer + id_vdq String :: String -> String + +Notice how the RHS of the signature is influenced by the LHS. + +This is in contrast to the function arrow ``->``, which is a non-dependent +quantifier:: + + putStrLn "Hello" :: IO () + putStrLn "World" :: IO () + +The type of ``putStrLn`` is ``String -> IO ()``. No matter what string we pass +as input, the result type ``IO ()`` does not depend on it. + +This notion of dependence is weaker than the one used in dependently-typed +languages (see :ref:`pi-types`). + +Terminology: Visible quantifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We say that ``forall a.`` is an *invisible* quantifier and ``forall a ->`` is a +*visible* quantifier. This notion of "visibility" is unrelated to implicit +quantification, which happens when the quantifier is omitted: :: -And of course, now we also have the option of using the bound ``t`` in a -subsequent pattern, as well as on the right-hand side of the lambda:: + id :: a -> a -- implicit quantification, invisible forall + id :: forall a. a -> a -- explicit quantification, invisible forall + id_vdq :: forall a -> a -> a -- explicit quantification, visible forall - -- For reference: id_vdq :: forall a -> a -> a - id_vdq = \(type t) (x :: t) -> x :: t - -- ↑ ↑ ↑ - -- bound used used +The property of "visibility" actually describes whether the corresponding type +argument is visible at the definition site and at call sites: :: -At use sites, we also instantiate this type variable explicitly:: + -- Invisible quantification + id :: forall a. a -> a + id x = x -- defn site: `a` is not mentioned + call_id = id True -- call site: `a` is invisibly instantiated to `Bool` - n = id_vdq (type Integer) 42 - s = id_vdq (type String) "Hello" + -- Visible quantification + id_vdq :: forall a -> a -> a + id_vdq t x = x -- defn site: `a` is visibly bound to `t` + call_id_vdq = id_vdq Bool True -- call site: `a` is visibly instantiated to `Bool` + +In the equation for ``id`` there is just one binder on the LHS, ``x``, and it +corresponds to the value argument, not to the type argument. Compare that with +the definition of ``id_vdq``:: + + id_vdq :: forall a -> a -> a + id_vdq t x = x + +This time we have two binders on the LHS: + +* ``t``, corresponding to ``forall a ->`` in the signature +* ``x``, corresponding to ``a ->`` in the signature + +The bound ``t`` can be used in subsequent patterns, as well as on the right-hand +side of the equation:: + + id_vdq :: forall a -> a -> a + id_vdq t (x :: t) = x :: t + -- ↑ ↑ ↑ + -- bound used used + +We use the terms "visible type argument" and "required type argument" +interchangeably. Relation to :extension:`TypeApplications` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,12 +122,12 @@ not reflected syntactically in the expression, it is invisible unless we use a Required type arguments are compulsory. They must appear syntactically at call sites:: - x1 = id_vdq (type Bool) True -- OK - x2 = id_vdq True -- not OK + x1 = id_vdq Bool True -- OK + x2 = id_vdq True -- not OK You may use an underscore to infer a required type argument:: - x3 = id_vdq (type _) True -- OK + x3 = id_vdq _ True -- OK That is, it is mostly a matter of syntax whether to use ``forall a.`` with type applications or ``forall a ->``. One advantage of required type arguments is that @@ -92,20 +144,265 @@ With :extension:`RequiredTypeArguments`, we can imagine a slightly different API sizeOf :: forall a -> Storable a => Int -If ``sizeOf`` had this type, we could write ``sizeOf (type Bool)`` without +If ``sizeOf`` had this type, we could write ``sizeOf Bool`` without passing a dummy value. +Required type arguments are erased during compilation. While the source program +appears to bind and pass required type arguments alongside value arguments, the +compiled program does not. There is no runtime overhead associated with required +type arguments relative to the usual, invisible type arguments. + Relation to :extension:`ExplicitNamespaces` ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``type`` keyword that we used in the examples is not actually part of -:extension:`RequiredTypeArguments`. It is guarded behind -:extension:`ExplicitNamespaces`. As described in the proposal, required type -arguments can be passed without a syntactic marker, making them syntactically -indistinguishble from ordinary function arguments:: +A required type argument is syntactically indistinguishable from a value +argument. In a function call ``f arg1 arg2 arg3``, it is impossible to tell, +without looking at the type of ``f``, which of the three arguments are required +type arguments, if any. + +At the same time, one of the design goals of GHC is to be able to perform name +resolution (find the binding sites of identifiers) without involving the type +system. Consider: :: + + data Ty = Int | Double | String deriving Show + main = print Int + +In this example, there are two constructors named ``Int`` in scope: + +* The **type constructor** ``Int`` of kind ``Type`` (imported from ``Prelude``) +* The **data constructor** ``Int`` of type ``Ty`` (defined locally) + +How does the compiler or someone reading the code know that ``print Int`` is +supposed to refer to the data constructor, not the type constructor? In GHC, +this is resolved as follows. Each identifier is said to occur either in +**type syntax** or **term syntax**, depending on the surrounding syntactic +context:: + + -- Examples of X in type syntax + type T = X -- RHS of a type synonym + data D = MkD X -- field of a data constructor declaration + a :: X -- RHS of a type signature + b = f (c :: X) -- RHS of a type signature (in expressions) + f (x :: X) = x -- RHS of a type signature (in patterns) + + -- Examples of X in term syntax + c X = a -- LHS of a function equation + c a = X -- RHS of a function equation + +One could imagine the entire program "zoned" into type syntax and term syntax, +each zone having its own rules for name resolution: + +* In type syntax, type constructors take precedence over data constructors. +* In term syntax, data constructors take precedence over type constructors. + +This means that in the ``print Int`` example, the data constructor is selected +solely based on the fact that the ``Int`` occurs in term syntax. This is firmly +determined before GHC attempts to type-check the expression, so the type of +``print`` does not influence which of the two ``Int``\s is passed to it. + +This may not be the desired behavior in a required type argument. Consider:: + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- "42" + s2 = vshow Double 42 -- "42.0" + +The function calls ``vshow Int 42`` and ``vshow Double 42`` are written in +*term* syntax, while the intended referents of ``Int`` and ``Double`` are the +respective *type* constructors. As long as there are no data constructors named +``Int`` or ``Double`` in scope, the example works as intended. However, if such +clashing constructor names are introduced, they may disrupt name resolution:: + + data Ty = Int | Double | String + + vshow :: forall a -> Show a => a -> String + vshow t x = show (x :: t) + + s1 = vshow Int 42 -- error: Expected a type, but ‘Int’ has kind ‘Ty’ + s2 = vshow Double 42 -- error: Expected a type, but ‘Double’ has kind ‘Ty’ + +In this example the intent was to refer to ``Int`` and ``Double`` as types, but +the names were resolved in favor of data constructors, resulting in type errors. + +The example can be fixed with the help of :extension:`ExplicitNamespaces`, which +allows embedding type syntax into term syntax using the ``type`` keyword:: + + s1 = vshow (type Int) 42 + s2 = vshow (type Double) 42 + +A similar problem occurs with list and tuple syntax. In type syntax, ``[a]`` is +the type of a list, i.e. ``Data.List.List a``. In term syntax, ``[a]`` is a +singleton list, i.e. ``a : []``. A naive attempt to use the list type as a +required type argument will result in a type error:: + + s3 = vshow [Int] [1,2,3] -- error: Expected a type, but ‘[Int]’ has kind ‘[Type]’ + +The problem is that GHC assumes ``[Int]`` to stand for ``Int : []`` instead of +the intended ``Data.List.List Int``. This, too, can be solved using the ``type`` keyword:: + + s3 = vshow (type [Int]) [1,2,3] + +Since the ``type`` keyword is merely a namespace disambiguation mechanism, it +need not apply to the entire type argument. Using it to disambiguate only a part +of the type argument is also valid:: + + f :: forall a -> ... -- `f`` is a function that expects a required type argument + + r1 = f (type (Either () Int)) -- `type` applied to the entire type argument + r2 = f (Either (type ()) Int) -- `type` applied to one part of it + r3 = f (Either (type ()) (type Int)) -- `type` applied to multiple parts + +That is, the expression ``Either (type ()) (type Int)`` does *not* indicate that +``Either`` is applied to two type arguments; rather, the entire expression is a +single type argument and ``type`` is used to disambiguate parts of it. + +Outside a required type argument, it is illegal to use ``type``: +:: + + r4 = type Int -- illegal use of ‘type’ + +Finally, there are types that require the ``type`` keyword only due to +limitations of the current implementation:: + + a1 = f (type (Int -> Bool)) -- function type + a2 = f (type (Read T => T)) -- constrained type + a3 = f (type (forall a. a)) -- universally quantified type + a4 = f (type (forall a. Read a => String -> a)) -- a combination of the above + +This restriction will be relaxed in a future release of GHC. + +Effect on implicit quantification +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Implicit quantification is said to occur when GHC inserts an implicit ``forall`` +to bind type variables:: + + const :: a -> b -> a -- implicit quantification + const :: forall a b. a -> b -> a -- explicit quantification + +Normally, implicit quantification is unaffected by term variables in scope: +:: + f a = ... -- the LHS binds `a` + where const :: a -> b -> a + -- implicit quantification over `a` takes place + -- despite the `a` bound on the LHS of `f` + +When :extension:`RequiredTypeArguments` is in effect, names bound in term syntax +are not implicitly quantified. This allows us to accept the following example: :: + + readshow :: forall a -> (Read a, Show a) => String -> String + readshow t s = show (read s :: t) + + s1 = readshow Int "42" -- "42" + s2 = readshow Double "42" -- "42.0" + +Note how ``t`` is bound on the LHS of a function equation (term syntax), and +then used in a type annotation (type syntax). Under the usual rules for implicit +quantification, the ``t`` would have been implicitly quantified: :: + + -- RequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is captured + -- ↑ ↑ + -- bound used + + -- NoRequiredTypeArguments + readshow t s = show (read s :: t) -- the `t` is implicitly quantified as follows: + readshow t s = show (read s :: forall t. t) + -- ↑ ↑ ↑ + -- bound bound used + +On the one hand, taking the current scope into account allows us to accept +programs like the one above. On the other hand, some existing programs will no +longer compile: :: + + a = 42 + f :: a -> a -- RequiredTypeArguments: the top-level `a` is captured + +Because of that, merely enabling :extension:`RequiredTypeArguments` might lead +to type errors of this form:: + + Term variable ‘a’ cannot be used here + (term variables cannot be promoted) + +There are two possible ways to fix this error:: + + a = 42 + f1 :: b -> b -- (1) use a different variable name + f2 :: forall a. a -> a -- (2) use an explicit forall + +If you are converting a large codebase to be compatible with +:extension:`RequiredTypeArguments`, consider using +:ghc-flag:`-Wterm-variable-capture` during the migration. It is a warning that +detects instances of implicit quantification incompatible with +:extension:`RequiredTypeArguments`: :: + + The type variable ‘a’ is implicitly quantified, + even though another variable of the same name is in scope: + ‘a’ defined at ... + +.. _pi-types: + +Relation to Π-types +~~~~~~~~~~~~~~~~~~~ + +Both ``forall a.`` and ``forall a ->`` are dependent quantifiers in the narrow +sense defined in :ref:`dependent-quantifier`. However, neither of them +constitutes a dependent function type (Π-type) that might be familiar to users +coming from dependently-typed languages or proof assistants. + +* Haskell has always had functions whose result *value* depends on + the argument *value*:: + + not True = False -- argument value: True; result value: False + (*2) 5 = 10 -- argument value: 5; result value: 10 + + This captures the usual idea of a function, denoted ``a -> b``. + +* Haskell also has functions whose result *type* depends on the argument *type*: + :: + + id @Int :: Int -> Int -- argument type: Int; result type: Int -> Int + id_vdq Bool :: Bool -> Bool -- argument type: Bool; result type: Bool -> Bool + + This captures the idea of parametric polymorphism, denoted ``forall a. b`` or + ``forall a -> b``. + +* Furthermore, Haskell has functions whose result *value* depends on the + argument *type*:: + + maxBound @Int8 = 127 -- argument type: Int8; result value: 127 + maxBound @Int16 = 32767 -- argument type: Int16; result value: 32767 + + This captures the idea of ad-hoc (class-based) polymorphism, + denoted ``C a => b``. + +* However, Haskell does **not** have direct support for functions whose result + *type* depends on the argument *value*. In the literature, these are often + called "dependent functions", or "Π-types". + + Consider: :: + + type F :: Bool -> Bool + type family F b where + F True = ... + F False = ... + + f :: Bool -> Bool + f True = ... + f False = ... + + In this example, we define a type family ``F`` to pattern-match on ``b`` at + the type level; and a function ``f`` to pattern-match on ``b`` at the term + level. However, it is impossible to quantify over ``b`` in such a way that + both ``F`` and ``f`` could be applied to it:: + + depfun :: forall (b :: Bool) -> F b -- Allowed + depfun b = ... (f b) ... -- Not allowed - n = id_vdq Integer 42 + It is illegal to pass ``b`` to ``f`` because ``b`` does not exist at runtime. + Types and type arguments are erased before runtime. -In this example we pass ``Integer`` as opposed to ``(type Integer)``. -This means that :extension:`RequiredTypeArguments` is not tied to the ``type`` -syntax, which belongs to :extension:`ExplicitNamespaces`. \ No newline at end of file +The :extension:`RequiredTypeArguments` extension does not add dependent +functions, which would be a much bigger step. Rather :extension:`RequiredTypeArguments` +just makes it possible for the type arguments of a function to be compulsory. \ No newline at end of file ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -2440,8 +2440,8 @@ of ``-W(no-)*``. For example: :: a = 15 - f :: a -> a -- Does ‘a’ refer to the term-level binding - -- or is it implicitly quantified? + f :: a -> a -- NoRequiredTypeArguments: The ‘a’ is implicitly quantified + -- RequiredTypeArguments: The ‘a’ refers to the term-level binding When :ghc-flag:`-Wterm-variable-capture` is enabled, GHC warns against implicit quantification that would stop working under :extension:`RequiredTypeArguments`. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c9496e0bbb41f494c66e430689841968e872be3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c9496e0bbb41f494c66e430689841968e872be3 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 Dec 13 01:22:46 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Tue, 12 Dec 2023 20:22:46 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Drop hard Xcode dependency Message-ID: <65790766c8544_393b78199988b024179b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - af01db06 by Artin Ghasivand at 2023-12-12T20:22:41-05:00 Remove the "Derived Constraint" argument of TcPluginSolver, docs - - - - - 53b88a84 by Vladislav Zavialov at 2023-12-12T20:22:41-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> - - - - - 3613a73f by Zubin Duggal at 2023-12-12T20:22:42-05:00 testsuite: use copy_files in T23405 This prevents the tree from being dirtied when the file is modified. - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9e17a97351fe824109cabdce67986b3fe0065f9...3613a73f2ae3277df9859932536597271a8d69df -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c9e17a97351fe824109cabdce67986b3fe0065f9...3613a73f2ae3277df9859932536597271a8d69df 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 Dec 13 07:33:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 02:33:34 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: rts/eventlog: Fix off-by-one in assertion Message-ID: <65795e4e81653_393b78225e2af02726c6@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 133722a6 by Ben Gamari at 2023-12-13T02:33:24-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. - - - - - 115875a5 by Ben Gamari at 2023-12-13T02:33:24-05:00 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. - - - - - d6c99bb8 by Ben Gamari at 2023-12-13T02:33:24-05:00 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. - - - - - e5e2ca22 by Artin Ghasivand at 2023-12-13T02:33:28-05:00 Remove the "Derived Constraint" argument of TcPluginSolver, docs - - - - - 3f6527b2 by Vladislav Zavialov at 2023-12-13T02:33:29-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> - - - - - 0a9fa9df by Zubin Duggal at 2023-12-13T02:33:29-05:00 testsuite: use copy_files in T23405 This prevents the tree from being dirtied when the file is modified. - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3613a73f2ae3277df9859932536597271a8d69df...0a9fa9df578ec1ac840597d1ab60571d5c98b2ac -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3613a73f2ae3277df9859932536597271a8d69df...0a9fa9df578ec1ac840597d1ab60571d5c98b2ac 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 Dec 13 10:37:43 2023 From: gitlab at gitlab.haskell.org (Sven Tennie (@supersven)) Date: Wed, 13 Dec 2023 05:37:43 -0500 Subject: [Git][ghc/ghc][wip/supersven/riscv64-ncg] 236 commits: hadrian: Bump index-state to allow building with ghc-9.6 Message-ID: <657989777a2f8_393b7826a30234303463@gitlab.mail> Sven Tennie pushed to branch wip/supersven/riscv64-ncg at Glasgow Haskell Compiler / GHC Commits: 40293d4e by Matthew Pickering at 2023-05-10T16:07:19+01:00 hadrian: Bump index-state to allow building with ghc-9.6 - - - - - 65023412 by Ben Gamari at 2023-05-11T12:49:10-04:00 users guide: Note that base release notes are highlights of changelog - - - - - e0f3aec8 by Simon Peyton Jones at 2023-05-15T18:34:25-04:00 Refactor the simplifier a bit to fix #22761 The core change in this commit, which fixes #22761, is that * In a Core rule, ru_rhs is always occ-analysed. This means adding a couple of calls to occurAnalyseExpr when building a Rule, in * GHC.Core.Rules.mkRule * GHC.Core.Opt.Simplify.Iteration.simplRules But diagosing the bug made me stare carefully at the code of the Simplifier, and I ended up doing some only-loosely-related refactoring. * I think that RULES could be lost because not every code path did addBndrRules * The code around lambdas was very convoluted It's mainly moving deck chairs around, but I like it more now. (cherry picked from commit e45eb82830d6de4d09abb548e190be980dd001b4) - - - - - 595edd68 by Josh Meredith at 2023-05-15T18:34:25-04:00 JS: Fix implementation of MK_JSVAL (cherry picked from commit bab232795865e9abb82b75c7e72329778e23a345) - - - - - dc291c00 by Josh Meredith at 2023-05-15T18:34:25-04:00 JS: fix implementation of forceBool to use JS backend syntax (cherry picked from commit 047e9d4f10e4124899887449dc52b9e72a7d3ea6) - - - - - 3db2b31b by Sebastian Graf at 2023-05-15T18:34:26-04:00 Simplifier: `countValArgs` should not count Type args (#23102) I observed miscompilations while working on !10088 caused by this. Fixes #23102. Metric Decrease: T10421 (cherry picked from commit 559a480427a841b5189f2e6a84a38b02a7c2b8a1) - - - - - 4532771a by Alexis King at 2023-05-15T18:34:26-04:00 bytecode: Fix bitmaps for BCOs used to tag tuples and prim call args fixes #23068 (cherry picked from commit bed3a292df532935426987e1f0c5eaa4f605407e) - - - - - f70b9c49 by Matthew Pickering at 2023-05-16T07:56:09-04:00 docs: Generate docs/index.html with version number * Generate docs/index.html to include the version of the ghc library * This also fixes the packageVersions interpolations which were - Missing an interpolation for `LIBRARY_ghc_VERSION` - Double quoting the version so that "9.7" was being inserted. Fixes #23121 (cherry picked from commit d7a768a415c3bd575a20b20ae9a3953aa5886ed7) - - - - - 6cd0f807 by Simon Peyton Jones at 2023-05-16T07:56:09-04:00 Transfer DFunId_ness onto specialised bindings Whether a binding is a DFunId or not has consequences for the `-fdicts-strict` flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does not apply because the constraint solver can create recursive groups of dictionaries. In #22549 this was fixed for the "normal" case, see Note [Do not strictify the argument dictionaries of a dfun]. However the loop still existed if the DFunId was being specialised. The problem was that the specialiser would specialise a DFunId and turn it into a VanillaId and so the demand analyser didn't know to apply special treatment to the binding anymore and the whole recursive group was optimised to bottom. The solution is to transfer over the DFunId-ness of the binding in the specialiser so that the demand analyser knows not to apply the `-fstrict-dicts`. Fixes #22549 (cherry picked from commit 3b0ea4809d92581a10e0e501a6fbd7339e8922bf) - - - - - 5637364e by Ben Gamari at 2023-05-16T07:56:09-04:00 nonmoving: Disable slop-zeroing As noted in #23170, the nonmoving GC can race with a mutator zeroing the slop of an updated thunk (in much the same way that two mutators would race). Consequently, we must disable slop-zeroing when the nonmoving GC is in use. Closes #23170 (cherry picked from commit d1bb16ed3e18a4f41fcfe31f0bf57dbaf589d6c5) - - - - - 373ec872 by Krzysztof Gogolewski at 2023-05-16T07:56:09-04:00 Fix unification with oversaturated type families unify_ty was incorrectly saying that F x y ~ T x are surely apart, where F x y is an oversaturated type family and T x is a tyconapp. As a result, the simplifier dropped a live case alternative (#23134). (cherry picked from commit 7c16f3be6e1ac92f87d752f12ad6c6e7b7fd6207) - - - - - ab677901 by Ben Gamari at 2023-05-16T07:56:09-04:00 nativeGen/AArch64: Fix bitmask immediate predicate Previously the predicate for determining whether a logical instruction operand could be encoded as a bitmask immediate was far too conservative. This meant that, e.g., pointer untagged required five instructions whereas it should only require one. Fixes #23030. (cherry picked from commit b8d783d24b9a617ad1e3038abeb75d322703ef65) - - - - - 7083db5a by Sylvain Henry at 2023-05-16T07:56:09-04:00 JS: fix thread-related primops (cherry picked from commit d442ac053f9ac7dbcc32318802daf686f377fe3d) - - - - - 35131c9d by Ben Gamari at 2023-05-16T07:56:09-04:00 rts: Initialize Array# header in listThreads# Previously the implementation of listThreads# failed to initialize the header of the created array, leading to various nastiness. Fixes #23071 (cherry picked from commit 52d3e9b4189440d26bad9c5a15f9420b67b1ca5b) - - - - - ac639721 by Ben Gamari at 2023-05-16T07:56:09-04:00 testsuite: Add test for #23071 (cherry picked from commit 1db30fe1dd38dd8ffedfadf3845706fcde02933b) - - - - - 1fdbbd8d by sheaf at 2023-05-16T07:56:09-04:00 Don't panic in ltPatersonSize The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it encountered a type family on the RHS, as usually these are not allowed (type families are not allowed on the RHS of class instances or of quantified constraints). However, it is possible to still encounter type families on the RHS after doing a bit of constraint solving, as seen in test case T23171. This could trigger the panic in the call to ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which is involved in avoiding loopy superclass constraints. This patch simply changes ltPatersonSize to return "I don't know, because there's a type family involved" in these cases. Fixes #23171 (cherry picked from commit df1a581188694479a583270548896245fc23b525) - - - - - 5292bdf8 by Sylvain Henry at 2023-05-17T11:43:28-04:00 JS: fix getpid (fix #23399) (cherry picked from commit 2972fd66f91cb51426a1df86b8166a067015e231) - - - - - 6c5fcaba by Josh Meredith at 2023-05-17T11:43:34-04:00 JS: Implement h$clock_gettime in the JavaScript RTS (#23360) (cherry picked from commit 5e3f9bb57680a40f6a9531e41dc2617c5f028e5c) - - - - - 86a9404a by Sylvain Henry at 2023-05-17T11:44:06-04:00 Fix GHCJS OS platform (fix #23346) (cherry picked from commit 2f571afe1c2aeb3f4dfca2012bc6b713144fd234) - - - - - 48da24c9 by Simon Peyton Jones at 2023-05-18T16:00:10-04:00 Make GHC.Types.Id.Make.shouldUnpackTy a bit more clever As #23307, GHC.Types.Id.Make.shouldUnpackTy was leaving money on the table, failing to unpack arguments that are perfectly unpackable. The fix is pretty easy; see Note [Recursive unboxing] (cherry picked from commit 902f0730b4c50f39b7767a346be324c98bf7a8a6) - - - - - 74b8e5bd by Alexis King at 2023-05-18T16:00:10-04:00 Use a uniform return convention in bytecode for unary results fixes #22958 (cherry picked from commit d85ed900b271109185251cb0494d51048a4cf213) - - - - - 4949111f by Alexis King at 2023-05-18T16:00:10-04:00 hadrian: Fix linker script flag for MergeObjects builder This fixes what appears to have been a typo in !9530. The `-t` flag just enables tracing on all versions of `ld` I’ve looked at, while `-T` is used to specify a linker script. It seems that this worked anyway for some reason on some `ld` implementations (perhaps because they automatically detect linker scripts), but the missing `-T` argument causes `gold` to complain. (cherry picked from commit 59aa4676a49b4f9d09c1cd3cc3b47c3c54b6ed80) - - - - - 27086298 by Krzysztof Gogolewski at 2023-05-18T16:00:10-04:00 Fix coercion optimisation for SelCo (#23362) setNominalRole_maybe is supposed to output a nominal coercion. In the SelCo case, it was not updating the stored role to Nominal, causing #23362. (cherry picked from commit d683b2e5b91a39a2bf16796f5800f605a0281004) - - - - - 5bd85c7d by Ben Gamari at 2023-05-18T16:00:10-04:00 hadrian: Fix mention of non-existent removeFiles function Previously Hadrian's bindist Makefile referred to a `removeFiles` function that was previously defined by the `make` build system. Since the `make` build system is no longer around, this function is now undefined. Naturally, make being make, this appears to be silently ignored instead of producing an error. Fix this by rewriting it to `rm -f`. Closes #23373. (cherry picked from commit c6cf9433e3d41e239265eaeff0fd02e6b45d5427) - - - - - 7607986e by sheaf at 2023-05-18T16:00:10-04:00 Don't panic in mkNewTyConRhs This function could come across invalid newtype constructors, as we only perform validity checking of newtypes once we are outside the knot-tied typechecking loop. This patch changes this function to fake up a stub type in the case of an invalid newtype, instead of panicking. This patch also changes "checkNewDataCon" so that it reports as many errors as possible at once. Fixes #23308 (cherry picked from commit c176ad1835ccfe55e2bde875b4a35e9d226ff657) - - - - - eaadcaa7 by Ryan Scott at 2023-05-18T16:00:10-04:00 Fix type variable substitution in gen_Newtype_fam_insts Previously, `gen_Newtype_fam_insts` was substituting the type variable binders of a type family instance using `substTyVars`, which failed to take type variable dependencies into account. There is similar code in `GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly, so this patch: 1. Factors out this code into a top-level `substATBndrs` function, and 2. Uses `substATBndrs` in `gen_Newtype_fam_insts`. Fixes #23329. (cherry picked from commit e8b72ff6e4aee1f889a9168df57bb1b00168fd21) - - - - - 14414247 by Ben Gamari at 2023-05-18T16:00:10-04:00 nonmoving: Fix style (cherry picked from commit abb6070f488120aef113b686e91b439fe6c3d272) - - - - - 4200590a by Ben Gamari at 2023-05-18T16:00:10-04:00 nonmoving: Deduplicate assertion (cherry picked from commit be2789014b208db5c471ab187e7dba2ebc59f8c8) - - - - - 80208941 by Ben Gamari at 2023-05-18T16:00:10-04:00 rts: Fix type issues in Sparks.h Adds explicit casts to satisfy a C++ compiler. (cherry picked from commit b90346392f5455bc4a6f6d86700296babc429a98) - - - - - 0a25b9df by Ben Gamari at 2023-05-18T16:00:10-04:00 rts: Use release ordering when storing thread labels Since this makes the ByteArray# visible from other cores. (cherry picked from commit da7b2b941d235a284d5685829c235a9e671a0336) - - - - - a70c277a by Ben Gamari at 2023-05-18T16:00:10-04:00 rts/BlockAlloc: Allow disabling of internal assertions These can be quite expensive and it is sometimes useful to compile a DEBUG RTS without them. (cherry picked from commit 5b7f65767fbc2967e01a13ee580598e976f5d225) - - - - - b4e5489f by Ben Gamari at 2023-05-18T16:00:10-04:00 rts/Sanity: Mark pinned_object_blocks (cherry picked from commit 6283144fb2e98f4c774950567e55575c1747d136) - - - - - 2ab18a83 by Ben Gamari at 2023-05-18T16:00:11-04:00 rts/Sanity: Look at nonmoving saved_filled lists (cherry picked from commit 9b52840412c920a1a1eed26df37262bc6c82c171) - - - - - 556c2544 by Ben Gamari at 2023-05-18T16:00:11-04:00 Evac: Squash data race in eval_selector_chain (cherry picked from commit 0edc543834d8172e54020c5272af1cf2d0b3437c) - - - - - 4023f814 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Clarify implementation This makes the intent of this implementation a bit clearer. (cherry picked from commit 7eab831a7d17eda3108da4702a447656cd62334c) - - - - - 88cc3f94 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Clarify comment (cherry picked from commit 532262b95b2eaa685a22279a8e54cc2e379e21ef) - - - - - f5a48ce6 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Add missing no-op in busy-wait loop (cherry picked from commit bd9cd84bbbb51f21c7b2b478e1f5971e2659b9fd) - - - - - 5c4aa7e2 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Don't push empty arrays to update remembered set Previously the write barrier of resizeSmallArray# incorrectly handled resizing of zero-sized arrays, pushing an invalid pointer to the update remembered set. Fixes #22931. (cherry picked from commit c4e6bfc801a79b73e94d363db1d3e65076e17981) - - - - - 661da5ee by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Fix handling of weak pointers This fixes an interaction between aging and weak pointer handling which prevented the finalization of some weak pointers. In particular, weak pointers could have their keys incorrectly marked by the preparatory collector, preventing their finalization by the subsequent concurrent collection. While in the area, we also significantly improve the assertions regarding weak pointers. Fixes #22327. (cherry picked from commit 92227b6022b35d87f6366c75e09ed495b7c3603e) - - - - - 568b2523 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Sanity check nonmoving large objects and compacts (cherry picked from commit ba7e7972ae14848a9ac41d5c6200d0aa5727ed72) - - - - - ce560ce4 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Sanity check mutable list Assert that entries in the nonmoving generation's generational remembered set (a.k.a. mutable list) live in nonmoving generation. (cherry picked from commit 71b038a1261754c38cf984f7c578621c3217c3bf) - - - - - a01dc8ab by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Don't show occupancy if we didn't collect live words (cherry picked from commit 99d144d56598965daba30aa73e6c598b3245bb0f) - - - - - 762f6ae1 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Fix tracking of FILLED_SWEEPING segments Previously we only updated the state of the segment at the head of each allocator's filled list. (cherry picked from commit 81d6cc551c7a843002495d3ffd2373ad00a52766) - - - - - 395b8572 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Assert state of swept segments (cherry picked from commit 58e53bc4d33dad76b3250997f1a8300d0041f387) - - - - - 6208cbae by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Handle new closures in nonmovingIsNowAlive We must conservatively assume that new closures are reachable since we are not guaranteed to mark such blocks. (cherry picked from commit 2db92e015655e7fc22e559020572bf23233ffaae) - - - - - 471b5fdc by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Don't clobber update rem sets of old capabilities Previously `storageAddCapabilities` (called by `setNumCapabilities`) would clobber the update remembered sets of existing capabilities when increasing the capability count. Fix this by only initializing the update remembered sets of the newly-created capabilities. Fixes #22927. (cherry picked from commit e4c3249f00a406a406b6f1190ca8be628b643042) - - - - - 229ae7e4 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Add missing write barriers in selector optimisation This fixes the selector optimisation, adding a few write barriers which are necessary for soundness. See the inline comments for details. Fixes #22930. (cherry picked from commit 1b06967176559d6b2b530dd16e127fa4479ae47f) - - - - - 8f39f2b3 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Post-sweep sanity checking (cherry picked from commit d4032690a8bf638f6d134cc6592d138eb018f102) - - - - - 6a25c84f by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Avoid n_caps race (cherry picked from commit 0baa8752aaefe80ca428fbfa0cbd4e620d67e1a7) - - - - - 7213e435 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Don't push if nonmoving collector isn't enabled (cherry picked from commit 5d3232baa78dd6f00fc040f75d8e9a8075bfbc07) - - - - - 251e2b4a by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Be more paranoid in segment tracking Previously we left various segment link pointers dangling. None of this wrong per se, but it did make it harder than necessary to debug. (cherry picked from commit 0a7eb0aa0bf7e7464e68ab9b6f4176771dcc3590) - - - - - 81fb5149 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Sync-phase mark budgeting Here we significantly improve the bound on sync phase pause times by imposing a limit on the amount of work that we can perform during the sync. If we find that we have exceeded our marking budget then we allow the mutators to resume, return to concurrent marking, and try synchronizing again later. Fixes #22929. (cherry picked from commit 7c817c0a4ab857e03d09526a481f63e313598c5b) - - - - - d8ad8043 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Allow pinned gen0 objects to be WEAK keys (cherry picked from commit ce22a3e2f2e8168f80d77807d79214e1cfbccb44) - - - - - d6deed34 by Ben Gamari at 2023-05-18T16:00:11-04:00 rts: Reenable assertion (cherry picked from commit 78746906d133765a9a4219eb34ed01e78f31344c) - - - - - d6826083 by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Move current segment array into Capability The current segments are conceptually owned by the mutator, not the collector. Consequently, it was quite tricky to prove that the mutator would not race with the collect due to this shared state. It turns out that such races are possible: when resizing the current segment array we may concurrently try to take a heap census. This will attempt to walk the current segment array, causing a data race. Fix this by moving the current segment array into `Capability`, where it belongs. Fixes #22926. (cherry picked from commit b500867a9eae6381e5c686aaa71ae069398eacb9) - - - - - 02289f9a by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Fix Note references Some references to Note [Deadlock detection under the non-moving collector] were missing an article. (cherry picked from commit 56e669c11208bba136c44ee7154b59e0d4d39c87) - - - - - 4b75a239 by Ben Gamari at 2023-05-18T16:00:11-04:00 rts/Sanity: Fix block count assertion with non-moving collector The nonmoving collector does not use `oldest_gen->blocks` to track its block list. However, it nevertheless updates `oldest_gen->n_blocks` to ensure that its size is accounted for by the storage manager. Consequently, we must not attempt to assert consistency between the two. (cherry picked from commit 4a7650d75752fcde2fc5bc23913e4116ae2ec582) - - - - - 4275ccfb by Ben Gamari at 2023-05-18T16:00:11-04:00 nonmoving: Don't call prepareUnloadCheck When the nonmoving GC is in use we do not call `checkUnload` (since we don't unload code) and therefore should not call `prepareUnloadCheck`, lest we run into assertions. (cherry picked from commit 96a5aaede899f95fb06dcdb9d0439bbea0f93e14) - - - - - 873df322 by Ben Gamari at 2023-05-18T16:00:11-04:00 rts: Encapsulate block allocator spinlock This makes it a bit easier to add instrumentation on this spinlock while debugging. (cherry picked from commit 6c6674cafefbb72f1b9c5b8a005fc62f905c50ea) - - - - - 8805864d by Ben Gamari at 2023-05-18T16:00:11-04:00 testsuite: Skip some tests when sanity checking is enabled (cherry picked from commit e84f716798e0d3431aa7ec42b243dc0998cb6444) - - - - - f01df851 by Ben Gamari at 2023-05-18T16:00:12-04:00 nonmoving: Fix unregisterised build (cherry picked from commit 3ae0f368542b24b2ee2cd102cf65db8db705c83c) - - - - - 3bc83d81 by Ben Gamari at 2023-05-18T16:00:12-04:00 nonmoving: Ensure that sanity checker accounts for saved_filled segments (cherry picked from commit 4eb9d06b00043e52be3cf828ccb92f0bb4c9e438) - - - - - 7c5657fc by Ben Gamari at 2023-05-18T16:00:12-04:00 hadrian: Add +boot_nonmoving_gc flavour transformer For using GHC bootstrapping to validate the non-moving GC. (cherry picked from commit f0cf384db038ff3b83770dbf11a89ecd20178899) - - - - - 04e8de8a by Ben Gamari at 2023-05-18T16:00:12-04:00 nonmoving: Move allocator into new source file (cherry picked from commit 487a8b580581e8f9b40974cf0e0a4e93f95e8665) - - - - - a7716f0b by Ben Gamari at 2023-05-18T16:00:12-04:00 nonmoving: Split out nonmovingAllocateGC (cherry picked from commit 8f374139f0b5f0a39861a7f9432070f78f9fbba0) - - - - - 01f2fef1 by Ben Gamari at 2023-05-18T16:00:12-04:00 testsuite: Mark ffi023 as broken due to #23089 (cherry picked from commit f1fd3ffbdccf471c43f3c36d6ecb4bd5da33c097) - - - - - db8e4d61 by Ben Gamari at 2023-05-18T16:00:12-04:00 testsuite: Skip T7160 in the nonmoving way Finalization order is different under the nonmoving collector. (cherry picked from commit a57f12b3f06afe29cbbc6eb0a887bcbe319f17f6) - - - - - 75fd54fe by Ben Gamari at 2023-05-18T16:00:12-04:00 rts: Capture GC configuration in a struct The number of distinct arguments passed to GarbageCollect was getting a bit out of hand. (cherry picked from commit f6f12a36346e19de7eed330537350d0b7420764a) - - - - - 19ad1ae5 by Ben Gamari at 2023-05-18T16:00:12-04:00 nonmoving: Non-concurrent collection (cherry picked from commit ba73a807edbb444c49e0cf21ab2ce89226a77f2e) - - - - - 15da0925 by Ben Gamari at 2023-05-18T16:00:12-04:00 gitlab-ci: Add job bootstrapping with nonmoving GC (cherry picked from commit 581e58ac80f98a9f5292ad13a9a984c2f5a1de21) - - - - - 7b39870b by Ben Gamari at 2023-05-21T14:30:51-04:00 nonmoving: Account for mutator allocations in bytes_allocated Previously we failed to account direct mutator allocations into the nonmoving heap against the mutator's allocation limit and `cap->total_allocated`. This only manifests during CAF evaluation (since we allocate the CAF's blackhole directly into the nonmoving heap). Fixes #23312. (cherry picked from commit b2cdb7dacc095142e29c0f28a956b7fa97cdb4b1) - - - - - 3d0a7cd3 by Teo Camarasu at 2023-05-21T14:45:11-04:00 Add regression test for #17574 This test currently fails in the nonmoving way (cherry picked from commit a56141a69842a78d56ec11be85a775eb703219bf) - - - - - f0f96536 by Teo Camarasu at 2023-05-21T14:45:20-04:00 fix: account for large and compact object stats with nonmoving gc Make sure that we keep track of the size of large and compact objects that have been moved onto the nonmoving heap. We keep track of their size and add it to the amount of live bytes in nonmoving segments to get the total size of the live nonmoving heap. Resolves #17574 (cherry picked from commit 20c6669fc46c567e00d3cdf22aa84479b6d8dc17) - - - - - 07243d1b by Ben Gamari at 2023-05-21T15:03:36-04:00 configure: Release 9.6.2 - - - - - 7e70df17 by Ben Gamari at 2023-05-22T20:18:09-04:00 docs: 9.6.2 release notes - - - - - 9a1dcec1 by Ben Gamari at 2023-05-22T20:18:17-04:00 configure: RELEASE=NO - - - - - 1972f6b5 by Cheng Shao at 2023-09-05T18:01:27+05:30 rts: use performBlockingMajorGC in hs_perform_gc and fix ffi023 This patch does a few things: - Add the missing RtsSymbols.c entry of performBlockingMajorGC - Make hs_perform_gc call performBlockingMajorGC, which restores previous behavior - Use hs_perform_gc in ffi023 - Remove rts_clearMemory() call in ffi023, it now works again in some test ways previously marked as broken. Fixes #23089 (cherry picked from commit b2d14d0b8ebb517139c08934a52791f21fe893f6) - - - - - fedc7d73 by sheaf at 2023-09-13T17:18:14+05:30 Propagate long-distance info in generated code When desugaring generated pattern matches, we skip pattern match checks. However, this ended up also discarding long-distance information, which might be needed for user-written sub-expressions. Example: ```haskell okay (GADT di) cd = let sr_field :: () sr_field = case getFooBar di of { Foo -> () } in case cd of { SomeRec _ -> SomeRec sr_field } ``` With sr_field a generated FunBind, we still want to propagate the outer long-distance information from the GADT pattern match into the checks for the user-written RHS of sr_field. Fixes #23445 (cherry picked from commit fbc8e04e5d8fb05ff60568042802ab2fb34e1a70) - - - - - 897b5689 by Richard Eisenberg at 2023-09-13T17:18:14+05:30 Don't suppress *all* Wanteds Code in GHC.Tc.Errors.reportWanteds suppresses a Wanted if its rewriters have unfilled coercion holes; see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. But if we thereby suppress *all* errors that's really confusing, and as #22707 shows, GHC goes on without even realising that the program is broken. Disaster. This MR arranges to un-suppress them all if they all get suppressed. Close #22707 (cherry picked from commit 1ed573a53ee454db240b9fb1a17e28c97b6eb53a) - - - - - bd38bb14 by Luite Stegeman at 2023-09-13T17:18:14+05:30 Delete created temporary subdirectories at end of session. This patch adds temporary subdirectories to the list of paths do clean up at the end of the GHC session. This fixes warnings about non-empty temporary directories. Fixes #22952 (cherry picked from commit f97c7f6d96c58579d630bc883929afc3d45d5c2b) - - - - - 0f4dfc0a by Matthew Pickering at 2023-09-13T17:18:14+05:30 Fix behaviour of -keep-tmp-files when used in OPTIONS_GHC pragma This fixes the behaviour of -keep-tmp-files when used in an OPTIONS_GHC pragma for files with module level scope. Instead of simple not deleting the files, we also need to remove them from the TmpFs so they are not deleted later on when all the other files are deleted. There are additional complications because you also need to remove the directory where these files live from the TmpFs so we don't try to delete those later either. I added two tests. 1. Tests simply that -keep-tmp-files works at all with a single module and --make mode. 2. The other tests that temporary files are deleted for other modules which don't enable -keep-tmp-files. Fixes #23339 (cherry picked from commit a24b83ddabac6b7eeb63db13884e4403f71375dd) - - - - - 2423c854 by Matthew Pickering at 2023-09-13T17:18:14+05:30 withDeferredDiagnostics: When debugIsOn, write landmine into IORef to catch use-after-free. Ticket #23305 reports an error where we were attempting to use the logger which was created by withDeferredDiagnostics after its scope had ended. This problem would have been caught by this patch and a validate build: ``` +*** Exception: Use after free +CallStack (from HasCallStack): + error, called at compiler/GHC/Driver/Make.hs:<line>:<column> in <package-id>:GHC.Driver.Make ``` This general issue is tracked by #20981 (cherry picked from commit dcf3288273d2418800e2dee97c937673a1d38a8f) - - - - - 35e4c00c by Matthew Pickering at 2023-09-13T17:18:14+05:30 Don't return complete HscEnv from upsweep By returning a complete HscEnv from upsweep the logger (as introduced by withDeferredDiagnostics) was escaping the scope of withDeferredDiagnostics and hence we were losing error messages. This is reminiscent of #20981, which also talks about writing errors into messages after their scope has ended. See #23305 for details. (cherry picked from commit 432c736c19446a011fca1f9485c67761c991bd42) - - - - - 8ee3adf4 by Ryan Scott at 2023-09-13T17:18:14+05:30 Add regression test for #23143 !10541, the fix for #23323, also fixes #23143. Let's add a regression test to ensure that it stays fixed. Fixes #23143. (cherry picked from commit 95b69cfb3d601eb3e6c5b1727c4cfef25ab87d68) - - - - - 01cb005a by Simon Peyton Jones at 2023-09-13T17:18:14+05:30 Don't report redundant Givens from quantified constraints This fixes #23323 See (RC4) in Note [Tracking redundant constraints] (cherry picked from commit 2b0c9f5ef026df6dd2637aacce05a11d74146296) - - - - - bc04ca51 by Ben Gamari at 2023-09-13T17:18:14+05:30 nativeGen: Explicitly set flags of text sections on Windows The binutils documentation (for COFF) claims, > If no flags are specified, the default flags depend upon the section > name. If the section name is not recognized, the default will be for the > section to be loaded and writable. We previously assumed that this would do the right thing for split sections (e.g. a section named `.text$foo` would be correctly inferred to be a text section). However, we have observed that this is not the case (at least under the clang toolchain used on Windows): when split-sections is enabled, text sections are treated by the assembler as data (matching the "default" behavior specified by the documentation). Avoid this by setting section flags explicitly. This should fix split sections on Windows. Fixes #22834. (cherry picked from commit 3ece9856d157c85511d59f9f862ab351bbd9b38b) - - - - - 3bc903b2 by Ben Gamari at 2023-09-13T17:18:14+05:30 nativeGen: Set explicit section types on all platforms (cherry picked from commit db7f7240b53c01447e44d2790ee37eacaabfbcf3) - - - - - be64c6e6 by Ben Gamari at 2023-09-13T17:18:14+05:30 testsuite: Add tests for #23146 Both lifted and unlifted variants. (cherry picked from commit 33cf4659f209ef8e97be188279216a2f4fe0cf51) - - - - - 7f2f7ac1 by Ben Gamari at 2023-09-13T17:18:15+05:30 codeGen: Fix some Haddocks (cherry picked from commit 76727617bccc88d1466ad6dc1442ab8ebb34f79a) - - - - - 6eb8e32a by Ben Gamari at 2023-09-13T17:18:15+05:30 codeGen: Give proper LFInfo to datacon wrappers As noted in `Note [Conveying CAF-info and LFInfo between modules]`, when importing a binding from another module we must ensure that it gets the appropriate `LambdaFormInfo` if it is in WHNF to ensure that references to it are tagged correctly. However, the implementation responsible for doing this, `GHC.StgToCmm.Closure.mkLFImported`, only dealt with datacon workers and not wrappers. This lead to the crash of this program in #23146: module B where type NP :: [UnliftedType] -> UnliftedType data NP xs where UNil :: NP '[] module A where import B fieldsSam :: NP xs -> NP xs -> Bool fieldsSam UNil UNil = True x = fieldsSam UNil UNil Due to its GADT nature, `UNil` produces a trivial wrapper $WUNil :: NP '[] $WUNil = UNil @'[] @~(<co:1>) which is referenced in the RHS of `A.x`. Due to the above-mentioned bug in `mkLFImported`, the references to `$WUNil` passed to `fieldsSam` were not tagged. This is problematic as `fieldsSam` expected its arguments to be tagged as they are unlifted. The fix is straightforward: extend the logic in `mkLFImported` to cover (nullary) datacon wrappers as well as workers. This is safe because we know that the wrapper of a nullary datacon will be in WHNF, even if it includes equalities evidence (since such equalities are not runtime relevant). Thanks to @MangoIV for the great ticket and @alt-romes for his minimization and help debugging. Fixes #23146. (cherry picked from commit 33a8c348cae5fd800c015fd8c2230b8066c7c0a4) - - - - - 81f2cceb by Rodrigo Mesquita at 2023-09-13T17:18:15+05:30 codeGen: Fix LFInfo of imported datacon wrappers As noted in #23231 and in the previous commit, we were failing to give a an LFInfo of LFCon to a nullary datacon wrapper from another module, failing to properly tag pointers which ultimately led to the segmentation fault in #23146. On top of the previous commit which now considers wrappers where we previously only considered workers, we change the order of the guards so that we check for the arity of the binding before we check whether it is a constructor. This allows us to (1) Correctly assign `LFReEntrant` to imported wrappers whose worker was nullary, which we previously would fail to do (2) Remove the `isNullaryRepDataCon` predicate: (a) which was previously wrong, since it considered wrappers whose workers had zero-width arguments to be non-nullary and would fail to give `LFCon` to them (b) is now unnecessary, since arity == 0 guarantees - that the worker takes no arguments at all - and the wrapper takes no arguments and its RHS must be an application of the worker to zero-width-args only. - we lint these two items with an assertion that the datacon `hasNoNonZeroWidthArgs` We also update `isTagged` to use the new logic in determining the LFInfos of imported Ids. The creation of LFInfos for imported Ids and this detail are explained in Note [The LFInfo of Imported Ids]. Note that before the patch to those issues we would already consider these nullary wrappers to have `LFCon` lambda form info; but failed to re-construct that information in `mkLFImported` Closes #23231, #23146 (I've additionally batched some fixes to documentation I found while investigating this issue) (cherry picked from commit 2fc18e9e784ccc775db8b06a5d10986588cce74a) - - - - - 9c99cd76 by Sebastian Graf at 2023-09-13T17:18:15+05:30 DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208) In #23208 we observed that the demand signature of a binder occuring in a RULE wasn't unleashed, leading to a transitively used binder being discarded as absent. The solution was to use the same code path that we already use for handling exported bindings. See the changes to `Note [Absence analysis for stable unfoldings and RULES]` for more details. I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a `VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our existing framework. As a result, I had to touch quite a few places in the code. This refactoring exposed a few small bugs around correct handling of bottoming demand environments. As a result, some strictness signatures now mention uniques that weren't there before which caused test output changes to T13143, T19969 and T22112. But these tests compared whole -ddump-simpl listings which is a very fragile thing to begin with. I changed what exactly they test for based on the symptoms in the corresponding issues. There is a single regression in T18894 because we are more conservative around stable unfoldings now. Unfortunately it is not easily fixed; let's wait until there is a concrete motivation before invest more time. Fixes #23208. (cherry picked from commit c30ac25f7dfaded58bb2ff85d4bffe662e4af8b1) - - - - - 0d642d43 by Matthew Craven at 2023-09-13T17:18:15+05:30 StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. (cherry picked from commit 65a442fccd081d9370ae4ee4e74f116139b5c2c8) - - - - - fbeb839d by Ben Gamari at 2023-09-13T17:18:15+05:30 hadrian: Always canonicalize topDirectory Hadrian's `topDirectory` is intended to provide an absolute path to the root of the GHC tree. However, if the tree is reached via a symlink this One question here is whether the `canonicalizePath` call is expensive enough to warrant caching. In a quick microbenchmark I observed that `canonicalizePath "."` takes around 10us per call; this seems sufficiently low not to worry. Alternatively, another approach here would have been to rather move the canonicalization into `m4/fp_find_root.m4`. This would have avoided repeated canonicalization but sadly path canonicalization is a hard problem in POSIX shell. Addresses #22451. (cherry picked from commit 5efa9ca545d8d33b9be4fc0ba91af1db38f19276) - - - - - 7ed005ca by aadaa_fgtaa at 2023-09-13T17:18:15+05:30 Optimise ELF linker (#23464) - cache last elements of `relTable`, `relaTable` and `symbolTables` in `ocInit_ELF` - cache shndx table in ObjectCode - run `checkProddableBlock` only with debug rts (cherry picked from commit b3e1436f968c0c36a27ea0339ee2554970b329fe) - - - - - 7f9a10c7 by Ben Gamari at 2023-09-13T17:18:15+05:30 rts: Ensure that pinned allocations respect block size Previously, it was possible for pinned, aligned allocation requests to allocate beyond the end of the pinned accumulator block. Specifically, we failed to account for the padding needed to achieve the requested alignment in the "large object" check. With large alignment requests, this can result in the allocator using the capability's pinned object accumulator block to service a request which is larger than `PINNED_EMPTY_SIZE`. To fix this we reorganize `allocatePinned` to consistently account for the alignment padding in all large object checks. This is a bit subtle as we must handle the case of a small allocation request filling the accumulator block, as well as large requests. Fixes #23400. (cherry picked from commit fd8c57694a00f6359bd66365f1284388c869ac60) - - - - - 1f788005 by Ben Gamari at 2023-09-13T17:18:15+05:30 testsuite: Add test for #23400 (cherry picked from commit 98185d5212fb0464dcbcca0ca2c33326a7a002e8) - - - - - 1ad2e1cd by Ben Gamari at 2023-09-13T17:18:15+05:30 base: Fix incorrect CPP guard This was guarded on `darwin_HOST_OS` instead of `defined(darwin_HOST_OS)`. (cherry picked from commit d7ef1704aeba451bd3e0efbdaaab2638ee1f0bc8) - - - - - 8dae53e2 by Ben Gamari at 2023-09-13T17:18:15+05:30 rts/Trace: Ensure that debugTrace arguments are used As debugTrace is a macro we must take care to ensure that the fact is clear to the compiler lest we see warnings. (cherry picked from commit 7c7d1f66d35f73a2faa898a33aa80cd276159dc2) - - - - - 622b09a8 by Ben Gamari at 2023-09-13T17:18:15+05:30 rts: Various warnings fixes (cherry picked from commit cb92051e3d85575ff6abd753c9b135930cc50cf8) - - - - - 9cdd8f41 by Ben Gamari at 2023-09-13T17:18:15+05:30 hadrian: Ignore warnings in unix and semaphore-compat (cherry picked from commit dec81dd1fd0475dde4929baae625d155387300bb) - - - - - 686a86b0 by Moisés Ackerman at 2023-09-13T17:35:18+05:30 Add failing test case for #23492 (cherry picked from commit 6074cc3cda9b9836c784942a1aa7f766fb142787) - - - - - 469da90f by Moisés Ackerman at 2023-09-13T17:35:18+05:30 Use generated src span for catch-all case of record selector functions This fixes #23492. The problem was that we used the real source span of the field declaration for the generated catch-all case in the selector function, in particular in the generated call to `recSelError`, which meant it was included in the HIE output. Using `generatedSrcSpan` instead means that it is not included. (cherry picked from commit 356a269258a50bf67811fe0edb193fc9f82dfad1) - - - - - ae8571ff by Matthew Pickering at 2023-09-13T17:35:18+05:30 Add -fpolymorphic-specialisation flag (off by default at all optimisation levels) Polymorphic specialisation has led to a number of hard to diagnose incorrect runtime result bugs (see #23469, #23109, #21229, #23445) so this commit introduces a flag `-fpolymorhphic-specialisation` which allows users to turn on this experimental optimisation if they are willing to buy into things going very wrong. Ticket #23469 (cherry picked from commit 9f01d14b5bc1c73828b2b061206c45b84353620e) - - - - - e90957af by Bryan Richter at 2023-09-13T17:35:18+05:30 Add missing void prototypes to rts functions See #23561. (cherry picked from commit 82ac6bf113526f61913943b911089534705984fb) - - - - - c1f910d0 by Ben Gamari at 2023-09-13T17:35:18+05:30 Define FFI_GO_CLOSURES The libffi shipped with Apple's XCode toolchain does not contain a definition of the FFI_GO_CLOSURES macro, despite containing references to said macro. Work around this by defining the macro, following the model of a similar workaround in OpenJDK [1]. [1] https://github.com/openjdk/jdk17u-dev/pull/741/files (cherry picked from commit 8b35e8caafeeccbf06b7faa70e807028a3f0ff43) - - - - - 36dc5121 by Ben Gamari at 2023-09-13T17:35:18+05:30 hadrian: Ensure that way-flags are passed to CC Previously the way-specific compilation flags (e.g. `-DDEBUG`, `-DTHREADED_RTS`) would not be passed to the CC invocations. This meant that C dependency files would not correctly reflect dependencies predicated on the way, resulting in the rather painful #23554. Closes #23554. (cherry picked from commit cca74dab6809f8cf7ffc2ec9df689e06aa425110) - - - - - b6bf7b43 by Krzysztof Gogolewski at 2023-09-13T17:35:18+05:30 Fix #23567, a specializer bug Found by Simon in https://gitlab.haskell.org/ghc/ghc/-/issues/23567#note_507834 The testcase isn't ideal because it doesn't detect the bug in master, unless doNotUnbox is removed as in https://gitlab.haskell.org/ghc/ghc/-/issues/23567#note_507692. But I have confirmed that with that modification, it fails before and passes afterwards. (cherry picked from commit bf9b9de0685e23c191722dfdb78d28b44f1cba05) - - - - - 2086ffb5 by Dave Barton at 2023-09-13T17:35:18+05:30 Fix some broken links and typos (cherry picked from commit 4457da2a7dba97ab2cd2f64bb338c904bb614244) - - - - - 62d117c3 by Andrew Lelechenko at 2023-09-13T17:35:18+05:30 Add since annotations for Data.Foldable1 (cherry picked from commit 054261dd319b505392458da7745e768847015887) - - - - - 1aef9974 by Ben Gamari at 2023-09-13T17:35:18+05:30 rts/RtsSymbols: Add AArch64 outline atomic operations Fixes #22012 by adding the symbols described in https://github.com/llvm/llvm-project/blob/main/llvm/docs/Atomics.rst#libcalls-atomic. Ultimately this would be better addressed by #22011, but this is a first step in the right direction and fixes the immediate symptom. Note that we dropped the `__arch64_cas16` operations as these provided by all platforms's compilers. Also, we don't link directly against the libgcc/compiler-rt definitions but rather provide our own wrappers to work around broken toolchains (e.g. https://bugs.gentoo.org/868018). Generated via https://gitlab.haskell.org/ghc/ghc/-/snippets/5733. (cherry picked from commit 1aa5733a4480420fdc146322d86dd143321a3da6) - - - - - d09e1901 by Matthew Pickering at 2023-09-13T17:35:18+05:30 driver: Fix -S with .cmm files There was an oversight in the driver which assumed that you would always produce a `.o` file when compiling a .cmm file. Fixes #23610 (cherry picked from commit 76983a0dca64dfb7e94aea0c4f494921f8513b41) - - - - - 380c8328 by sheaf at 2023-09-13T17:35:19+05:30 Valid hole fits: don't panic on a Given The function GHC.Tc.Errors.validHoleFits would end up panicking when encountering a Given constraint. To fix this, it suffices to filter out the Givens before continuing. Fixes #22684 (cherry picked from commit 630e302617a4a3e00d86d0650cb86fa9e6913e44) - - - - - e7406e9e by Matthew Pickering at 2023-09-13T17:35:19+05:30 simplifier: Correct InScopeSet in rule matching The in-scope set passedto the `exprIsLambda_maybe` call lacked all the in-scope binders. @simonpj suggests this fix where we augment the in-scope set with the free variables of expression which fixes this failure mode in quite a direct way. Fixes #23630 (cherry picked from commit 4f5538a8e2a8b9bc490bcd098fa38f6f7e9f4d73) - - - - - db6198a0 by Ben Gamari at 2023-09-13T17:35:19+05:30 rts/win32: Ensure reliability of IO manager shutdown When the Win32 threaded IO manager shuts down, `ioManagerDie` sends an `IO_MANAGER_DIE` event to the IO manager thread using the `io_manager_event` event object. Finally, it will closes the event object, and invalidate `io_manager_event`. Previously, `readIOManagerEvent` would see that `io_manager_event` is invalid and return `0`, suggesting that everything is right with the world. This meant that if `ioManagerDie` invalidated the handle before the event manager was blocked on the event we would end up in a situation where the event manager would never realize it was asked to shut down. Fix this by ensuring that `readIOManagerEvent` instead returns `IO_MANAGER_DIE` when we detect that the event object has been invalidated by `ioManagerDie`. Fixes #23691. (cherry picked from commit 01db1117e18f140987f608a78f3e929242d6f00c) - - - - - 48917633 by Ben Gamari at 2023-09-13T17:35:19+05:30 codeGen: Ensure that TSAN is aware of writeArray# write barriers By using a proper release store instead of a fence. (cherry picked from commit aca20a5d4fde1c6429c887624bb95c9b54b7af73) - - - - - aa375afc by Ben Gamari at 2023-09-13T17:35:19+05:30 codeGen: Ensure that array reads have necessary barriers This was the cause of #23541. (cherry picked from commit 453c0531f2edf49b75c73bc45944600d8d7bf767) - - - - - c728db01 by Ben Gamari at 2023-09-13T17:35:19+05:30 linker/PEi386: Don't sign-extend symbol section number Previously we incorrectly interpreted PE section numbers as signed values. However, this isn't the case; rather, it's an unsigned 16-bit number with a few special bit-patterns (0xffff and 0xfffe). This resulted in #22941 as the linker would conclude that the sections were invalid. Fixing this required quite a bit of refactoring. Closes #22941. (cherry picked from commit 0eb54c050e46f447224167166dd6d2805ca8cdf5) - - - - - f939a7f7 by Simon Peyton Jones at 2023-09-13T17:53:09+05:30 Look both ways when looking for quantified equalities When looking up (t1 ~# t2) in the quantified constraints, check both orientations. Forgetting this led to #23333. (cherry picked from commit 40c7daed0c971e58e86a8189f82f72e9213af8b6) - - - - - 938a6614 by Krzysztof Gogolewski at 2023-09-18T10:07:51+05:30 Show an error when we cannot default a concrete tyvar Fixes #23153 (cherry picked from commit 0da18eb79540181ae9835e73d52ba47ec79fff6b) (cherry picked from commit 39574e3402ac33eb346e508da2667b9f337a590f) - - - - - fbcf62e8 by sheaf at 2023-09-18T15:26:52+05:30 Handle ConcreteTvs in inferResultToType This patch fixes two issues. 1. inferResultToType was discarding the ir_frr information, which meant some metavariables ended up being MetaTvs instead of ConcreteTvs. This function now creates new ConcreteTvs as necessary, instead of always creating MetaTvs. 2. startSolvingByUnification can make some type variables concrete. However, it didn't return an updated type, so callers of this function, if they don't zonk, might miss this and accidentally perform a double update of a metavariable. We now return the updated type from this function, which avoids this issue. Fixes #23154 (cherry picked from commit 9ab9b30ec1affe22b188f9a6637ac3bdea75bdba) - - - - - a650cd0a by Krzysztof Gogolewski at 2023-09-18T15:26:52+05:30 Use tcInferFRR to prevent bad generalisation Fixes #23176 (cherry picked from commit 4b89bb54a1d1d6a7b30a6bbfd21eed5d85506813) - - - - - 9aedbee5 by Sven Tennie at 2023-09-19T11:40:57+05:30 x86 Codegen: Implement MO_S_MulMayOflo for W16 (cherry picked from commit 6c88c2ba89b33a22793a168ad781a086eb110769) - - - - - dc2487ba by Sven Tennie at 2023-09-19T11:40:57+05:30 x86 CodeGen: MO_S_MulMayOflo better error message for rep > W64 It's useful to see which value made the pattern match fail. (If it ever occurs.) (cherry picked from commit 5f1154e0e3339dd1cabf7a7129337d8aa191fca7) - - - - - d2db0289 by Sven Tennie at 2023-09-19T11:40:57+05:30 x86 CodeGen: Implement MO_S_MulMayOflo for W8 This case wasn't handled before. But, the test-primops test suite showed that it actually might appear. (cherry picked from commit e8c9a95febf7b18476fec816effc95cb3fcb93de) - - - - - 94db871c by Sven Tennie at 2023-09-19T11:40:57+05:30 Add test for %mulmayoflo primop The test expects a perfect implementation with no false positives. (cherry picked from commit a36f9dc94823c75fb789710bc67b92e87a630440) - - - - - 86e43bdb by Ben Gamari at 2023-09-19T11:40:57+05:30 testsuite: Mark MulMayOflo_full as broken rather than skipping To ensure that we don't accidentally fix it. See #23742. (cherry picked from commit fd7ce39c70f8922e26b8be8a5fc4d6797987f66f) - - - - - 65037411 by Ben Gamari at 2023-09-19T11:40:57+05:30 nativeGen/AArch64: Fix sign extension in MulMayOflo Previously the 32-bit implementations of MulMayOflo would use the a non-sensical sign-extension mode. Rewrite these to reflect what gcc 11 produces. Also similarly rework the 16- and 8-bit cases. This now passes the MulMayOflo tests in ghc/test-primops> in all four widths, including the precision tests. Fixes #23721. (cherry picked from commit 824092f28f52d32b6ea3cd26e1e576524ee24969) - - - - - a6846677 by Ben Gamari at 2023-09-19T11:40:57+05:30 compiler: Fingerprint more code generation flags Previously our recompilation check was quite inconsistent in its coverage of non-optimisation code generation flags. Specifically, we failed to account for most flags that would affect the behavior of generated code in ways that might affect the result of a program's execution (e.g. `-feager-blackholing`, `-fstrict-dicts`) Closes #23369. (cherry picked from commit d1c92bf3b4b0b07a6a652f8fc31fd7b62465bf71) - - - - - c559cc62 by Andreas Klebinger at 2023-09-19T11:40:57+05:30 Arm: Fix lack of zero-extension for 8/16 bit add/sub with immediate. For 32/64bit we can avoid explicit extension/zeroing as the instructions set the full width of the registers. When doing 16/8bit computation we have to put a bit more work in so we can't use the fast path. Fixes #23749 for 9.4. (cherry picked from commit 0bb44f695bd008f03644e3d306566c50c5bd528c) - - - - - bc6429b7 by Ryan Scott at 2023-09-19T11:40:57+05:30 Restore mingwex dependency on Windows This partially reverts some of the changes in !9475 to make `base` and `ghc-prim` depend on the `mingwex` library on Windows. It also restores the RTS's stubs for `mingwex`-specific symbols such as `_lock_file`. This is done because the C runtime provides `libmingwex` nowadays, and moreoever, not linking against `mingwex` requires downstream users to link against it explicitly in difficult-to-predict circumstances. Better to always link against `mingwex` and prevent users from having to do the guesswork themselves. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10360#note_495873 for the discussion that led to this. (cherry picked from commit 2b1a4abe3f5935ca58c84c6073e6bdfa5160832f) - - - - - dbcb04bd by Ryan Scott at 2023-09-19T11:40:57+05:30 RtsSymbols.c: Remove mingwex symbol stubs As of !9475, the RTS now links against `ucrt` instead of `msvcrt` on Windows, which means that the RTS no longer needs to declare stubs for the `__mingw_*` family of symbols. Let's remove these stubs to avoid confusion. Fixes #23309. (cherry picked from commit 289547580b6f2808ee123f106c3118b716486d5b) - - - - - a5af5c1a by Jaro Reinders at 2023-09-19T11:40:58+05:30 Make STG rewriter produce updatable closures (cherry picked from commit 3930d793901d72f42b1535c85b746f32d5f3b677) - - - - - c0bec55a by Ben Gamari at 2023-09-19T11:40:58+05:30 users-guide: Support both distutils and packaging As noted in #23818, some old distributions (e.g. Debian 9) only include `distutils` while newer distributions only include `packaging`. Fixes #23818. (cherry picked from commit d814bda97994df01139c2a9bcde915dc86ef2927) - - - - - 77386227 by Ben Gamari at 2023-09-19T11:40:58+05:30 users-guide: Ensure extlinks is compatible with Sphinx <4 The semantics of the `extlinks` attribute annoyingly changed in Sphinx 4. Reflect this in our configuration. See #22690. Fixes #23807. (cherry picked from commit 1726db3f39f1c41b92b1bdf45e9dc054b401e782) - - - - - 9c046c69 by Krzysztof Gogolewski at 2023-09-19T11:40:58+05:30 Fix MultiWayIf linearity checking (#23814) Co-authored-by: Thomas BAGREL <thomas.bagrel at tweag.io> (cherry picked from commit edd8bc43566b3f002758e5d08c399b6f4c3d7443) - - - - - 53c0184a by Gergő Érdi at 2023-09-19T11:40:58+05:30 If we have multiple defaulting plugins, then we should zonk in between them after any defaulting has taken place, to avoid a defaulting plugin seeing a metavariable that has already been filled. Fixes #23821. (cherry picked from commit 1d92f2dff6d1a170a44488d73cef81292591d120) - - - - - 776647bf by Gergő Érdi at 2023-09-19T11:40:58+05:30 Improvements to the documentation of defaulting plugins Based on @simonpj's draft and comments in !11117 (cherry picked from commit eaee4d296a0782c1acfde610ed3f0a7c7668c06c) - - - - - bdf011e2 by Matthew Pickering at 2023-09-19T11:40:58+05:30 driver: Check transitive closure of haskell package dependencies when deciding whether to relink We were previously just checking whether direct package dependencies had been modified. This caused issues when compiling without optimisations as we wouldn't relink the direct dependency if one of its dependenices changed. Fixes #23724 (cherry picked from commit 291d81aef8083290da0d2ce430fbc5e5a33bdb6e) - - - - - 692b26d1 by Ben Gamari at 2023-09-19T11:40:58+05:30 rts: Fix invalid symbol type I suspect this code is dead since we haven't observed this failing despite the obviously incorrect macro name. (cherry picked from commit 9861f787a8323d03311e30851b10fdf100717afb) - - - - - 9ab41a89 by Ben Gamari at 2023-09-19T11:40:58+05:30 testsuite: Add simple test exercising C11 atomics in GHCi See #22012. (cherry picked from commit 03ed6a9a634fd6c3ef35e9c5428b4a911e3f0add) - - - - - b2331e11 by Ben Gamari at 2023-09-19T11:40:58+05:30 rts/RtsSymbols: Add AArch64 outline atomic operations Fixes #22012 by adding the symbols described in https://github.com/llvm/llvm-project/blob/main/llvm/docs/Atomics.rst#libcalls-atomic. Ultimately this would be better addressed by #22011, but this is a first step in the right direction and fixes the immediate symptom. Note that we dropped the `__arch64_cas16` operations as these provided by all platforms's compilers. Also, we don't link directly against the libgcc/compiler-rt definitions but rather provide our own wrappers to work around broken toolchains (e.g. https://bugs.gentoo.org/868018). Generated via https://gitlab.haskell.org/ghc/ghc/-/snippets/5733. (cherry picked from commit 1aa5733a4480420fdc146322d86dd143321a3da6) - - - - - 661b4908 by Matthew Craven at 2023-09-19T11:40:58+05:30 Unarise: Split Rubbish literals in function args Fixes #23914. Also adds a check to STG lint that these args are properly unary or nullary after unarisation (cherry picked from commit da30f0beb9e1820500382da02ffce96da959fa84) - - - - - 582fc7d5 by Simon Peyton Jones at 2023-09-19T11:40:58+05:30 Tiny refactor canEtaReduceToArity was only called internally, and always with two arguments equal to zero. This patch just specialises the function, and renames it to cantEtaReduceFun. No change in behaviour. (cherry picked from commit 236a134eab4c0a3aae30752a3d580c083f4e6b57) - - - - - e32a4856 by Simon Peyton Jones at 2023-09-19T11:40:58+05:30 Fix eta reduction Issue #23922 showed that GHC was bogusly eta-reducing a join point. We should never eta-reduce (\x -> j x) to j, if j is a join point. It is extremly difficult to trigger this bug. It took me 45 mins of trying to make a small tests case, here immortalised as T23922a. (cherry picked from commit 6840012e5bb8f5c13e4bf7a4e4cbba0b06420aaa) - - - - - 428438cd by Andreas Klebinger at 2023-09-19T11:40:58+05:30 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 (cherry picked from commit e5c00092a13f1a8cf53df2469e027012743cf59a) - - - - - ef74f5fb by Krzysztof Gogolewski at 2023-09-19T11:40:58+05:30 Fix wrong role in mkSelCo_maybe In the Lint failure in #23938, we start with a coercion Refl :: T a ~R T a, and call mkSelCo (SelTyCon 1 nominal) Refl. The function incorrectly returned Refl :: a ~R a. The returned role should be nominal, according to the SelCo rule: co : (T s1..sn) ~r0 (T t1..tn) r = tyConRole tc r0 i ---------------------------------- SelCo (SelTyCon i r) : si ~r ti In this test case, r is nominal while r0 is representational. (cherry picked from commit e0aa8c6e3a8b6004eca9349e5b705b8a767050aa) - - - - - ceb1e37a by Finley McIlwaine at 2023-09-19T11:40:58+05:30 Add -dipe-stats flag This is useful for seeing which info tables have information. (cherry picked from commit cc52c358316ac8210f80da80db6b0c620dd5bdc3) - - - - - 2e9adfc4 by Finley McIlwaine at 2023-09-19T11:40:58+05:30 Add -finfo-table-map-with-fallback -finfo-table-map-with-stack The -fno-info-table-map-with-stack flag omits STACK info tables from the info table map, and the -fno-info-table-map-with-fallback flag omits info tables with defaulted source locations from the map. In a test on the Agda codebase the build results were about 7% smaller when both of those types of tables were omitted. Adds a test that verifies that passing each combination of these flags results in the correct output for -dipe-stats, which is disabled for the js backend since profiling is not implemented. This commit also refactors a lot of the logic around extracting info tables from the Cmm results and building the info table map. This commit also fixes some issues in the users guide rst source to fix warnings that were noticed while debugging the documentation for these flags. Fixes #23702 (cherry picked from commit 261c4acbfdaf5babfc57ab0cef211edb66153fb1) - - - - - 3bb59347 by Finley McIlwaine at 2023-09-19T22:26:43+05:30 Refactor estimation of stack info table provenance This commit greatly refactors the way we compute estimated provenance for stack info tables. Previously, this process was done using an entirely separate traversal of the whole Cmm code stream to build the map from info tables to source locations. The separate traversal is now fused with the Cmm code generation pipeline in GHC.Driver.Main. This results in very significant code generation speed ups when -finfo-table-map is enabled. In testing, this patch reduces code generation times by almost 30% with -finfo-table-map and -O0, and 60% with -finfo-table-map and -O1 or -O2 . Fixes #23103 (cherry picked from commit d99c816f7b5727a3f344960e02a1932187ea093f) - - - - - 448c885d by Finley McIlwaine at 2023-09-19T22:26:43+05:30 Add a test checking overhead of -finfo-table-map We want to make sure we don't end up with poor codegen performance resulting from -finfo-table-map again as in #23103. This test adds a performance test tracking total allocations while compiling ExactPrint with -finfo-table-map. (cherry picked from commit d3e0124c1157a4a423d86a1dc1d7e82c6d32ef06) - - - - - ec164fcb by Ben Gamari at 2023-09-19T22:26:43+05:30 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. (cherry picked from commit b33113c86ce5888ff5edfd6d3dd95772d3c8abce) - - - - - b6bd8c09 by Sylvain Henry at 2023-09-19T22:26:43+05:30 Add missing int64/word64-to-double/float rules (#23907) CLC proposal: https://github.com/haskell/core-libraries-committee/issues/203 (cherry picked from commit 5126a2fef0385e206643b6af0543d10ff0c219d8) - - - - - 9bc1ab68 by Matthew Pickering at 2023-09-19T22:26:43+05:30 Build vanilla alpine bindists We currently attempt to build and distribute fully static alpine bindists (ones which could be used on any linux platform) but most people who use the alpine bindists want to use alpine to build their own static applications (for which a fully static bindist is not necessary). We should build and distribute these bindists for these users whilst the fully-static bindist is still unusable. Fixes #23349 (cherry picked from commit 29be39ba3f187279b19cf451f2d8f58822edab4f) - - - - - 1bd57554 by Matthew Craven at 2023-09-19T22:26:43+05:30 Bump bytestring submodule to 0.11.5.1 (cherry picked from commit 43578d60bfc478e7277dcd892463cec305400025) - - - - - 374f6f0d by Zubin Duggal at 2023-09-19T22:26:43+05:30 Bump bytestring submodule to 0.11.5.2 (#23789) (cherry picked from commit a98ae4ec6f4325c32c86cc0726947b6ecf4d047a) - - - - - 8ca3c034 by Zubin Duggal at 2023-09-19T22:26:43+05:30 Bump filepath submodule to 1.4.100.4 Bump bytestring submodule to 0.11.5.2 - - - - - f29969ca by Zubin Duggal at 2023-09-19T22:26:43+05:30 Update haddock submodule - - - - - 2000339c by Zubin Duggal at 2023-09-19T22:29:31+05:30 ci: Update bootstrap matrix for ghc 9.2.8, 9.4.7 and 9.6.2 Also add bootstrap plans for 9.2.{6..8}, 9.4.{4..6}, 9.6.{1,2} - - - - - 21e34882 by Zubin Duggal at 2023-09-19T22:29:31+05:30 user-guide: Add note that #23520 and -Wincomplete-record-updates is broken - - - - - 835be43c by Zubin Duggal at 2023-09-19T22:29:31+05:30 users-guide: Remove package list from older release notes (#18904) - - - - - ea651dae by Zubin Duggal at 2023-09-20T00:49:41+05:30 Prepare release 9.6.3 Metric Decrease: MultiComponentModules MultiComponentModulesRecomp MultiLayerModules MultiLayerModulesRecomp T10421 T12150 T12234 T12425 T13035 T13701 T13719 T15164 T16875 T18140 T18304 T18698a T18698b T18923 T20049 T9198 T9961 hard_hole_fits Metric Decrease 'compile_time/bytes allocated': T21839r Metric Increase 'runtime/max_bytes_used': T21839r Metric Increase 'runtime/peak_megabytes_allocated': T21839r - - - - - 96c483eb by Zubin Duggal at 2023-09-20T04:46:15+05:30 ci: Revert update to hadrian-bootstrap-sources from 2000339cbe66a2d9c7a106d6060a37fa11fc472d These made the Gitlab runner fail in mysterious ways when run with RELEASE_JOB=yes. We will distribute older bootstrap sources for now, instead of bumping all images to a newer docker revision that might break things - - - - - 4d9abf1e by Zubin Duggal at 2023-09-20T13:36:44+05:30 Update haddock submodule to 2.29.1 to restore GHC 9.2 compatibility. - - - - - 4031def4 by Ben Gamari at 2023-09-20T13:39:50+05:30 gitlab-ci: Only mark linker_unload_native as broken in static jobs This test passes on dynamically-linked Alpine. (cherry picked from commit f356a7e8ec8ec3d6b2b30fd175598b9b80065d87) - - - - - 5279ff76 by Ben Gamari at 2023-09-20T13:41:34+05:30 gitlab-ci: Mark T22012 as broken on CentOS 7 Due to #23979. (cherry picked from commit 4cec2feca335377f3b8e4aa448f8997760f5fb64) - - - - - 5c623d3d by Zubin Duggal at 2023-09-20T20:43:09+05:30 configure: Set RELEASE=yes - - - - - 6819b70a by Zubin Duggal at 2023-09-21T15:29:00+05:30 testsuite: Mark linker_unload_native as fragile See #23993. This test is fragile on Alpine (dynamic) but we don't have a way to mark it as fragile on only that platform, so marking it as fragile on all platforms. - - - - - c8d8cc97 by Moritz Angermann at 2023-12-12T18:20:23+01:00 Bring back old aarch64 test-suite - - - - - 2d99bca2 by Moritz Angermann at 2023-12-12T18:20:23+01:00 Add RV64 backend - - - - - 2fa25a90 by Moritz Angermann at 2023-12-12T18:20:23+01:00 Add RV64 notes - - - - - 55058315 by Moritz Angermann at 2023-12-12T18:20:24+01:00 Fixup Rebase mistake - - - - - 4bf3eaed by Sven Tennie at 2023-12-12T18:20:24+01:00 Remove TAB character The whitespace linter doesn't like it. - - - - - 6f43b90d by Sven Tennie at 2023-12-12T18:20:24+01:00 Fix compiler warning about importing GHC.Utils.Panic.Plain in CodeGen.Platform.h - - - - - a914cd5f by Sven Tennie at 2023-12-12T18:20:24+01:00 Pretty-print registers by their alias names The alias name is easier to memorize and simplifies reasoning about what's going on. - - - - - 6afdc32f by Sven Tennie at 2023-12-12T18:20:24+01:00 Fix getAmode: Only signed 12bit immediates The symptom to find this was a too big immediate in a LW instruction in test arr020: Error: illegal operands `lw t0,4016(t0)' - - - - - f0875bfa by Ben Gamari at 2023-12-12T18:20:24+01:00 hadrian: Pass CROSS_EMULATOR to runtests.py - - - - - ea621884 by Ben Gamari at 2023-12-12T18:20:24+01:00 testsuite/driver: Add basic support for testing cross-compilers - - - - - 3cfc91d2 by Sven Tennie at 2023-12-12T18:20:24+01:00 Add OR and ORI instructions ORR doesn't exist on RISCV. OR with register load is used when the immediate is too big for ORI (i.e. >12bits.) - - - - - 2eb5df1a by Sven Tennie at 2023-12-12T18:20:24+01:00 Refine TODO comment: Stack frame header size is 2 * 8 byte The stack frame header should contain two registers: ra and previous fp - - - - - 1b0b0491 by Sven Tennie at 2023-12-12T18:20:24+01:00 Fix MOV with immediate There are three cases: - Fits in a 12bit immediate slot -> ADDI - Fits in 32bit -> %hi / %lo piecewise loading - Else: Let the assembler solve this issue for now, LI - - - - - c8b7cf19 by Sven Tennie at 2023-12-12T18:20:24+01:00 Add DIV and REM REM calculates the remainder and replaces the more complex logic copied from AARCH64. - - - - - b7ce383b by Sven Tennie at 2023-12-12T18:20:24+01:00 Fix: LDRB -> LB, LDRH -> LH A simple translation of these instructions from ARM to RISCV. Add panic-ing pattern matches to fetch the outstanding STR and LDR cases. - - - - - 05b03431 by Sven Tennie at 2023-12-12T18:20:24+01:00 Implement MO_S_Shr and truncateReg These store and load on the stack to move values in changed widths into registers. - - - - - 40498410 by Sven Tennie at 2023-12-12T18:20:24+01:00 CmmInt 0 should refer to zero register A constant 0 can always be taken from the zero register. - - - - - 2dbc849c by Sven Tennie at 2023-12-12T18:20:24+01:00 Fix signed shift right This includes overhauling the sign extension and width truncation logic. - - - - - c74a9a31 by Sven Tennie at 2023-12-12T18:20:24+01:00 Replace SXTH & SXTB Both do not exist on RISCV64. While touching the sign extension code, also fix the integer calling convention in this sense and update the sign extension note. - - - - - 3ad1a720 by Sven Tennie at 2023-12-12T18:20:24+01:00 Allow truncation to from smaller to larger Width This is used as inverse of sign extension to 64bit at many places. - - - - - 3da8c87e by Sven Tennie at 2023-12-12T18:20:24+01:00 Implement MO_NOT: Replace MVN MVN does not exist in RV64. Replace it by pseudo-instr not's effective assembly. - - - - - 049125d4 by Sven Tennie at 2023-12-12T18:20:24+01:00 Replace UXTB & UXTH, Fix UDIV Replace UXTB and UXTB with truncateReg as these instructions do not exist in RISCV64. UDIV is named DIVU in RISCV64. - - - - - 40928235 by Sven Tennie at 2023-12-12T18:20:24+01:00 Implement XOR Delete EOR which does not exist on RISCV64. - - - - - d32e58ef by Sven Tennie at 2023-12-12T18:20:24+01:00 Rename UDIV -> DIVU That's how unsigned div is called on RISCV64. This should avoid confusion. - - - - - a7104960 by Sven Tennie at 2023-12-12T18:20:24+01:00 Delete unused EON It does not exist on RISCV64. - - - - - e6c41bb7 by Sven Tennie at 2023-12-12T18:27:46+01:00 WIP: MO_S_MulMayOflo - - - - - 91401476 by Moritz Angermann at 2023-12-12T18:30:03+01:00 float: first stab at supporting float ins - - - - - 58f91052 by Sven Tennie at 2023-12-12T18:34:22+01:00 Fix & test MulMayOflo - - - - - 79689c43 by Sven Tennie at 2023-12-12T18:34:25+01:00 Cleanup the MulMayOflo story - - - - - dd38ba33 by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement MO_ReadBarrier and MO_WriteBarrier The levels are taken from SMP.h write_barrier() and load_load_barrier(). - - - - - 202f3a04 by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement MO_AtomicRead and MO_AtomicWrite - - - - - bfc92699 by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement register -> stack spilling - - - - - 0d12b3b7 by Sven Tennie at 2023-12-12T18:34:25+01:00 Add free reg counts for trivColorable - - - - - 0553c3a3 by Sven Tennie at 2023-12-12T18:34:25+01:00 Fix immediate operand related guards For most operations, the immediate's boundaries are those of a 12bit integer. - - - - - 1b115a61 by Sven Tennie at 2023-12-12T18:34:25+01:00 Assign x31 to be IP register And, use it for register spilling. - - - - - e9c43006 by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement MO_FS_Conv and MO_SF_Conv (integer <-> float conversion) - - - - - bae53d45 by Sven Tennie at 2023-12-12T18:34:25+01:00 Fix MO_U_Shr (UBFX does not exist in RISCV ISA) - - - - - f2693c99 by Sven Tennie at 2023-12-12T18:34:25+01:00 Fix (CmmLit (CmmInt w i)) where i doesn't fit in w - - - - - 65ff4fb6 by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement MOV for ImmInt immediates These cases were likely just forgotten. - - - - - 809f5a83 by Sven Tennie at 2023-12-12T18:34:25+01:00 Load integers in their positive representation and don't sign extend unsigned values in foreign C calls Otherwise, the sign bits mess up everything! - - - - - 4e6f1b67 by Sven Tennie at 2023-12-12T18:34:25+01:00 Just narrow all CmmLit . CmmInt to the expected width There may appear immediates that don't fit the size. Just truncate them with narrowU. Otherwise, some bit operations fail for the highest bit. - - - - - 8f9471bc by Sven Tennie at 2023-12-12T18:34:25+01:00 Implement MO_UU_Conv Expect zero extended (!) register. If the source Width is smaller or equal to the target Width just move (copy) the value. Otherwise (target Width is smaller), truncate it. We don't need to care about sign-extension, as this mach op is unsigned. - - - - - adcf450d by Sven Tennie at 2023-12-12T18:34:25+01:00 CmmLoad: Load sub-words unsigned (no sign-extension) The contract is that each operation should leave sub-words zero-extended. This fixes the test (test-primops): // Failed: // 0::W64 - (~(zext[W32→W64](load[W32](0x8c::W64)))) // ((0 :: bits64) - (~%zx64(bits32[buffer + (140 :: bits64)]))) // 0x8f8e8d8d /= 0xffffffff8f8e8d8d test(bits64 buffer) { bits64 ret; ret = ((0 :: bits64) - (~%zx64(bits32[buffer + (140 :: bits64)]))); return (ret); } - - - - - eade684e by Sven Tennie at 2023-12-12T18:34:26+01:00 Annotate more instructions - - - - - 8819dd7b by Sven Tennie at 2023-12-12T18:34:26+01:00 Truncate after left shift Shifted values may exceed the target Width. - - - - - 5c3c7be0 by Sven Tennie at 2023-12-12T18:34:26+01:00 MO_SS_Conv: Don't give up the highest bit for sign According to this test, reducing the value for the sign is not correct. narrow[W32→W8](sext[W16→W32](load[W16](0x223972::W64))) test ( bits64 buffer ) { bits64 ret; (ret) = prim %popcnt8(%lobits8(%sx32(bits16[buffer + (2242930 :: bits64)]))); return (ret); } 4 /= 5 - - - - - 986bfcca by Sven Tennie at 2023-12-12T18:34:26+01:00 Unsigned remainder (modulo): REMU - - - - - a83fc290 by Sven Tennie at 2023-12-12T18:34:26+01:00 Fix loading 12bit < imm <= 32bit immediates The prior version sign extended the immediate. - - - - - 37e70daf by Sven Tennie at 2023-12-12T18:35:38+01:00 WIP: Check C calling convention - - - - - bc2320b8 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix & test C calling convention (parameters) I think the gist is: Sub-word ints are sign-extended, sub-word words are give as is, because they were truncated before. - - - - - da8858b3 by Sven Tennie at 2023-12-12T18:35:41+01:00 Truncate C return values to their expected width Otherwise, values that may be too big are floating around. - - - - - 1f913f51 by Sven Tennie at 2023-12-12T18:35:41+01:00 Single precision float comparisons - - - - - 6714dc98 by Sven Tennie at 2023-12-12T18:35:41+01:00 Float conditional jumps - - - - - 0508838f by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float absolute (fabs) - - - - - 6680e07d by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float negation - - - - - cc4e6859 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix unsigned float loading - - - - - 254161ee by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float comparisions - - - - - ad2163b5 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float calling convention (a bit) If fp regs are taken, use go regs instead. - - - - - a7b3893d by Sven Tennie at 2023-12-12T18:35:41+01:00 Add calling conv test for doubles - - - - - 768576f3 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float -> int conversion (width) - - - - - 2f5354b2 by Sven Tennie at 2023-12-12T18:35:41+01:00 MO_FS_Conv: Truncate register after conversion Otherwise, sign-extension bits may stay around. - - - - - 8722ede9 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float operation attributes This is its own little hell... - - - - - 296e5157 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix MO_FF_CONV The instruction needs precision suffixes to be valid. - - - - - 0d6dccdb by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix wrong fcvt widths - - - - - 81106e84 by Sven Tennie at 2023-12-12T18:35:41+01:00 Sign-extend branche conditionals W32 -> W64 Otherwise, negative ints are used as positive ints. - - - - - d8dd2e78 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix float NE: Needed width - - - - - 7ec45201 by Sven Tennie at 2023-12-12T18:35:41+01:00 Fix TrivColorable register counts - - - - - 0401a90b by Sven Tennie at 2023-12-13T11:37:09+01:00 Fix MulMayOflo test - - - - - 16 changed files: - .gitlab-ci.yml - .gitlab/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - compiler/CodeGen.Platform.h - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/Cmm.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PIC.hs - compiler/GHC/CmmToAsm/Ppr.hs - + compiler/GHC/CmmToAsm/RV64-notes.md - + compiler/GHC/CmmToAsm/RV64.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba3b2d609c1908876ca68d7dec6b83c4a71f7757...0401a90b7b75db4f1b5e5ac476ec5d4b759ccff5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ba3b2d609c1908876ca68d7dec6b83c4a71f7757...0401a90b7b75db4f1b5e5ac476ec5d4b759ccff5 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 Dec 13 10:50:36 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 13 Dec 2023 05:50:36 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/9.6.4-backports Message-ID: <65798c7ccb944_393b78272724d830613c@gitlab.mail> Zubin pushed new branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/9.6.4-backports 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 Dec 13 11:34:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 06:34:13 -0500 Subject: [Git][ghc/ghc][master] 3 commits: rts/eventlog: Fix off-by-one in assertion Message-ID: <657996b5bcdf1_393b78282f3be0320050@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 2 changed files: - rts/eventlog/EventLog.c - rts/include/Stg.h Changes: ===================================== rts/eventlog/EventLog.c ===================================== @@ -136,12 +136,12 @@ static void postBlockMarker(EventsBuf *eb); static void closeBlockMarker(EventsBuf *ebuf); static StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum); -static StgBool hasRoomForVariableEvent(EventsBuf *eb, uint32_t payload_bytes); +static StgBool hasRoomForVariableEvent(EventsBuf *eb, StgWord payload_bytes); static void freeEventLoggingBuffer(void); static void ensureRoomForEvent(EventsBuf *eb, EventTypeNum tag); -static int ensureRoomForVariableEvent(EventsBuf *eb, StgWord16 size); +static int ensureRoomForVariableEvent(EventsBuf *eb, StgWord size); static inline void postWord8(EventsBuf *eb, StgWord8 i) { @@ -180,7 +180,7 @@ static inline void postString(EventsBuf *eb, const char *buf) { if (buf) { const int len = strlen(buf); - ASSERT(eb->begin + eb->size > eb->pos + len); + ASSERT(eb->begin + eb->size > eb->pos + len + 1); memcpy(eb->pos, buf, len); eb->pos += len; } @@ -1220,7 +1220,7 @@ void postHeapProfBegin(StgWord8 profile_id) 1+8+4 + modSelector_len + descrSelector_len + typeSelector_len + ccSelector_len + ccsSelector_len + retainerSelector_len + bioSelector_len + 7; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_HEAP_PROF_BEGIN); postPayloadSize(&eventBuf, len); postWord8(&eventBuf, profile_id); @@ -1272,7 +1272,7 @@ void postHeapProfSampleString(StgWord8 profile_id, ACQUIRE_LOCK(&eventBufMutex); StgWord label_len = strlen(label); StgWord len = 1+8+label_len+1; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_STRING); postPayloadSize(&eventBuf, len); postWord8(&eventBuf, profile_id); @@ -1293,7 +1293,7 @@ void postHeapProfCostCentre(StgWord32 ccID, StgWord module_len = strlen(module); StgWord srcloc_len = strlen(srcloc); StgWord len = 4+label_len+module_len+srcloc_len+3+1; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_HEAP_PROF_COST_CENTRE); postPayloadSize(&eventBuf, len); postWord32(&eventBuf, ccID); @@ -1316,7 +1316,7 @@ void postHeapProfSampleCostCentre(StgWord8 profile_id, if (depth > 0xff) depth = 0xff; StgWord len = 1+8+1+depth*4; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_COST_CENTRE); postPayloadSize(&eventBuf, len); postWord8(&eventBuf, profile_id); @@ -1342,7 +1342,7 @@ void postProfSampleCostCentre(Capability *cap, if (depth > 0xff) depth = 0xff; StgWord len = 4+8+1+depth*4; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_PROF_SAMPLE_COST_CENTRE); postPayloadSize(&eventBuf, len); postWord32(&eventBuf, cap->no); @@ -1372,7 +1372,7 @@ void postProfBegin(void) static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) { StgWord len = 8 + 2 + strlen(p->arg_kinds)+1 + strlen(p->str)+1 + 8 + strlen(p->ticky_json)+1; - ensureRoomForVariableEvent(eb, len); + CHECK(!ensureRoomForVariableEvent(eb, len)); postEventHeader(eb, EVENT_TICKY_COUNTER_DEF); postPayloadSize(eb, len); @@ -1439,7 +1439,7 @@ void postIPE(const InfoProvEnt *ipe) // 1 null after each string // 1 colon between src_file and src_span StgWord len = 8+table_name_len+1+closure_desc_len+1+ty_desc_len+1+label_len+1+module_len+1+src_file_len+1+src_span_len+1; - ensureRoomForVariableEvent(&eventBuf, len); + CHECK(!ensureRoomForVariableEvent(&eventBuf, len)); postEventHeader(&eventBuf, EVENT_IPE); postPayloadSize(&eventBuf, len); postWord64(&eventBuf, (StgWord) INFO_PTR_TO_STRUCT(ipe->info)); @@ -1496,6 +1496,7 @@ void resetEventsBuf(EventsBuf* eb) eb->marker = NULL; } +STG_WARN_UNUSED_RESULT StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) { uint32_t size = sizeof(EventTypeNum) + sizeof(EventTimestamp) + eventTypes[eNum].size; @@ -1507,9 +1508,10 @@ StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) } } -StgBool hasRoomForVariableEvent(EventsBuf *eb, uint32_t payload_bytes) +STG_WARN_UNUSED_RESULT +StgBool hasRoomForVariableEvent(EventsBuf *eb, StgWord payload_bytes) { - uint32_t size = sizeof(EventTypeNum) + sizeof(EventTimestamp) + + StgWord size = sizeof(EventTypeNum) + sizeof(EventTimestamp) + sizeof(EventPayloadSize) + payload_bytes; if (eb->pos + size > eb->begin + eb->size) { @@ -1524,16 +1526,19 @@ void ensureRoomForEvent(EventsBuf *eb, EventTypeNum tag) if (!hasRoomForEvent(eb, tag)) { // Flush event buffer to make room for new event. printAndClearEventBuf(eb); + ASSERT(hasRoomForEvent(eb, tag)); } } -int ensureRoomForVariableEvent(EventsBuf *eb, StgWord16 size) +STG_WARN_UNUSED_RESULT +int ensureRoomForVariableEvent(EventsBuf *eb, StgWord size) { if (!hasRoomForVariableEvent(eb, size)) { // Flush event buffer to make room for new event. printAndClearEventBuf(eb); - if (!hasRoomForVariableEvent(eb, size)) + if (!hasRoomForVariableEvent(eb, size)) { return 1; // Not enough space + } } return 0; } ===================================== rts/include/Stg.h ===================================== @@ -200,6 +200,7 @@ #define STG_UNUSED GNUC3_ATTRIBUTE(__unused__) #define STG_USED GNUC3_ATTRIBUTE(__used__) +#define STG_WARN_UNUSED_RESULT GNUC3_ATTRIBUTE(warn_unused_result) /* Prevent functions from being optimized. See Note [Windows Stack allocations] */ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c9496e0bbb41f494c66e430689841968e872be3...0e0f41c0e3d9c67fc669e975060e88bccdc7d823 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1c9496e0bbb41f494c66e430689841968e872be3...0e0f41c0e3d9c67fc669e975060e88bccdc7d823 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 Dec 13 11:34:43 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 06:34:43 -0500 Subject: [Git][ghc/ghc][master] Remove the "Derived Constraint" argument of TcPluginSolver, docs Message-ID: <657996d340ecc_393b78280f14c8323340@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 64e724c8 by Artin Ghasivand at 2023-12-13T06:34:20-05:00 Remove the "Derived Constraint" argument of TcPluginSolver, docs - - - - - 1 changed file: - docs/users_guide/extending_ghc.rst Changes: ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -594,7 +594,7 @@ is defined thus: , tcPluginStop :: s -> TcPluginM () } - type TcPluginSolver = EvBindsVar -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult + type TcPluginSolver = EvBindsVar -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult type TcPluginRewriter = RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64e724c8fd417065484c2e25bdb6971080a0ce42 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64e724c8fd417065484c2e25bdb6971080a0ce42 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 Dec 13 11:35:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 06:35:39 -0500 Subject: [Git][ghc/ghc][master] EPA: Move tokens into GhcPs extension fields (#23447) Message-ID: <6579970befd5f_393b78280e37ec32668d@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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> - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6d97dd202ed9fd84a146dd2cd2cea7fc91e825 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe6d97dd202ed9fd84a146dd2cd2cea7fc91e825 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 Dec 13 11:36:13 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 06:36:13 -0500 Subject: [Git][ghc/ghc][master] testsuite: use copy_files in T23405 Message-ID: <6579972df779_393b78282aea2c32992c@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1 changed file: - testsuite/tests/ghci/T23405/all.T Changes: ===================================== testsuite/tests/ghci/T23405/all.T ===================================== @@ -1 +1 @@ -test('T23405', [extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) +test('T23405', [copy_files,extra_files(['T23405.hs'])], ghci_script, ['T23405.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8106e695bb912e60a338908a2b6efc5b0644c9c1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8106e695bb912e60a338908a2b6efc5b0644c9c1 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 Dec 13 13:11:01 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Wed, 13 Dec 2023 08:11:01 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <6579ad657ab3_393b782b1ae7c8343510@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: a24a24f7 by Sebastian Graf at 2023-12-13T14:08:16+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 16 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,50 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline most applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2206,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1149,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1211,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1226,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1510,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1733,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1891,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,12 +2060,27 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs @@ -2012,6 +2105,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2138,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,23 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a24a24f77d84c2f96df458dcc701a0d44bc7e81f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a24a24f77d84c2f96df458dcc701a0d44bc7e81f 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 Dec 13 13:11:52 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Wed, 13 Dec 2023 08:11:52 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <6579ad98c4044_393b782b26ba943439ac@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: e89883d1 by Sebastian Graf at 2023-12-13T14:11:33+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 16 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,50 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline most applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2206,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1149,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1211,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1226,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1510,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1733,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1891,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2060,34 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + is_lifted = not is_unlifted + is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2105,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2138,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,23 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e89883d158217fbc54de901b0de20364310e2bc9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e89883d158217fbc54de901b0de20364310e2bc9 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 Dec 13 13:50:52 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 13 Dec 2023 08:50:52 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 16 commits: Ensure unconstrained instance dictionaries get IPE info Message-ID: <6579b6bcb78d6_393b782b40fd14358820@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 2827a7d2 by Finley McIlwaine at 2023-12-13T19:20:41+05:30 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 (cherry picked from commit 69abb1714ade3059593297f3a5faec4c07d1f984) - - - - - 2277e03b by Simon Peyton Jones at 2023-12-13T19:20:41+05:30 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. (cherry picked from commit 8e05c54a8cb7e5ad2d584fad5b5ad878dd5488b6) - - - - - d2a6c616 by Andreas Klebinger at 2023-12-13T19:20:41+05:30 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 (cherry picked from commit 2adc050857a9c1b992040fbfd55fbe65b2851b19) - - - - - d1cf338e by Ben Gamari at 2023-12-13T19:20:41+05:30 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. (cherry picked from commit f6b2751f58df5f4f83caa7a7ca56e66659d02b09) - - - - - 47b44106 by Ben Gamari at 2023-12-13T19:20:41+05:30 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. (cherry picked from commit 8f6010b98f560200997a9d84a4e07bfd0ad6e496) - - - - - af883b4e by Sylvain Henry at 2023-12-13T19:20:41+05:30 Rts: expose rtsOutOfBoundsAccess symbol (cherry picked from commit cbe4400d2690104053ec544cf7d0a9a13ee914ee) - - - - - f8ba6d16 by Sylvain Henry at 2023-12-13T19:20:41+05:30 Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066) bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a". (cherry picked from commit fe0675770b66a9ed393884d96e276b8d116fa2a2) - - - - - c134e66c by Sylvain Henry at 2023-12-13T19:20:41+05:30 Bignum: fix right shift of negative BigNat with native backend (cherry picked from commit cc1625b1ffbdf086b8380bacd35abc8d85861637) - - - - - 52965752 by Sylvain Henry at 2023-12-13T19:20:41+05:30 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. (cherry picked from commit 72c7380cb780933825bc84924908e01ce0495dc4) - - - - - a71b71c4 by Moritz Angermann at 2023-12-13T19:20:42+05:30 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. (cherry picked from commit dafc47091c9107dcf81e1e80a105f59211927c89) (cherry picked from commit 8e7a2065e433aa56552b335d420b5bf925082078) - - - - - a6b63221 by Moritz Angermann at 2023-12-13T19:20:42+05:30 [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. (cherry picked from commit df81536f2e53abf521a05eb1e482a076f5849c21) - - - - - 9c2b99fb by Moritz Angermann at 2023-12-13T19:20:42+05:30 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" | ^ (cherry picked from commit e99cf237f84db34be0468a893b10394d6b364bce) - - - - - 4313138f by Ilias Tsitsimpis at 2023-12-13T19:20:42+05:30 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 (cherry picked from commit 257c2807587624592813a42e06a05c5fc34cb38c) (cherry picked from commit b2a03315f6336e2708ff54689f2241eb38198dd5) - - - - - 16f541ee by Moritz Angermann at 2023-12-13T19:20:42+05:30 [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. (cherry picked from commit 34f06334025521c2440ebedb0237697fbcc3c6de) - - - - - 8067b88b by Claudio Bley at 2023-12-13T19:20:42+05:30 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 (cherry picked from commit d561073727186c7b456c9ef113ccb7fc0df4560e) - - - - - 86d07f72 by Zubin Duggal at 2023-12-13T19:20:42+05:30 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 (cherry picked from commit 8db8d2fd1c881032b1b360c032b6d9d072c11723) - - - - - 30 changed files: - 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/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/PPC/Instr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/X86.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToCmm/CgUtils.hs - compiler/GHC/Types/Var.hs - ghc/GHCi/UI.hs - hadrian/doc/flavours.md - hadrian/src/Settings/Flavours/Validate.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs - libraries/ghc-bignum/src/GHC/Num/BigNat.hs - m4/find_ld.m4 - rts/RtsMessages.c - rts/RtsSymbols.c - rts/include/rts/Messages.h - rts/linker/PEi386.c - rts/sm/NonMoving.h - + testsuite/tests/driver/T24196/T24196.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64272ddcf2de1a81e5baacee538bf9c440dfb9bd...86d07f7230bfc00fcecb9881f900b96ef1ff4bf2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64272ddcf2de1a81e5baacee538bf9c440dfb9bd...86d07f7230bfc00fcecb9881f900b96ef1ff4bf2 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 Dec 13 14:08:20 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 13 Dec 2023 09:08:20 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 16 commits: Ensure unconstrained instance dictionaries get IPE info Message-ID: <6579bad46b40f_393b782cdbea0835966b@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 51d41567 by Finley McIlwaine at 2023-12-13T19:38:08+05:30 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 (cherry picked from commit 69abb1714ade3059593297f3a5faec4c07d1f984) - - - - - a9099ed0 by Simon Peyton Jones at 2023-12-13T19:38:08+05:30 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. (cherry picked from commit 8e05c54a8cb7e5ad2d584fad5b5ad878dd5488b6) - - - - - 3a04a7cd by Andreas Klebinger at 2023-12-13T19:38:08+05:30 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 (cherry picked from commit 2adc050857a9c1b992040fbfd55fbe65b2851b19) - - - - - ba0a72a1 by Ben Gamari at 2023-12-13T19:38:08+05:30 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. (cherry picked from commit f6b2751f58df5f4f83caa7a7ca56e66659d02b09) - - - - - 7c57f3fc by Ben Gamari at 2023-12-13T19:38:08+05:30 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. (cherry picked from commit 8f6010b98f560200997a9d84a4e07bfd0ad6e496) - - - - - c50e7300 by Sylvain Henry at 2023-12-13T19:38:08+05:30 Rts: expose rtsOutOfBoundsAccess symbol (cherry picked from commit cbe4400d2690104053ec544cf7d0a9a13ee914ee) - - - - - 68599387 by Sylvain Henry at 2023-12-13T19:38:08+05:30 Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066) bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a". (cherry picked from commit fe0675770b66a9ed393884d96e276b8d116fa2a2) - - - - - 39b69628 by Sylvain Henry at 2023-12-13T19:38:08+05:30 Bignum: fix right shift of negative BigNat with native backend (cherry picked from commit cc1625b1ffbdf086b8380bacd35abc8d85861637) - - - - - 74fcb5ae by Sylvain Henry at 2023-12-13T19:38:08+05:30 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. (cherry picked from commit 72c7380cb780933825bc84924908e01ce0495dc4) - - - - - 5b958702 by Moritz Angermann at 2023-12-13T19:38:08+05:30 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. (cherry picked from commit dafc47091c9107dcf81e1e80a105f59211927c89) (cherry picked from commit 8e7a2065e433aa56552b335d420b5bf925082078) - - - - - 1bd9b941 by Moritz Angermann at 2023-12-13T19:38:08+05:30 [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. (cherry picked from commit df81536f2e53abf521a05eb1e482a076f5849c21) - - - - - ebd2a21b by Moritz Angermann at 2023-12-13T19:38:08+05:30 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" | ^ (cherry picked from commit e99cf237f84db34be0468a893b10394d6b364bce) - - - - - 15061169 by Ilias Tsitsimpis at 2023-12-13T19:38:08+05:30 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 (cherry picked from commit 257c2807587624592813a42e06a05c5fc34cb38c) (cherry picked from commit b2a03315f6336e2708ff54689f2241eb38198dd5) - - - - - e9c4127d by Moritz Angermann at 2023-12-13T19:38:08+05:30 [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. (cherry picked from commit 34f06334025521c2440ebedb0237697fbcc3c6de) - - - - - b770316a by Claudio Bley at 2023-12-13T19:38:08+05:30 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 (cherry picked from commit d561073727186c7b456c9ef113ccb7fc0df4560e) - - - - - 1335ec32 by Zubin Duggal at 2023-12-13T19:38:08+05:30 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 (cherry picked from commit 8db8d2fd1c881032b1b360c032b6d9d072c11723) - - - - - 30 changed files: - 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/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/PPC/Instr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/X86.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToCmm/CgUtils.hs - compiler/GHC/Types/Var.hs - ghc/GHCi/UI.hs - hadrian/doc/flavours.md - hadrian/src/Settings/Flavours/Validate.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs - libraries/ghc-bignum/src/GHC/Num/BigNat.hs - m4/find_ld.m4 - rts/RtsMessages.c - rts/RtsSymbols.c - rts/include/rts/Messages.h - rts/linker/PEi386.c - rts/sm/NonMoving.h - + testsuite/tests/driver/T24196/T24196.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86d07f7230bfc00fcecb9881f900b96ef1ff4bf2...1335ec32c1accc5398623b42389e59aac179fb2e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86d07f7230bfc00fcecb9881f900b96ef1ff4bf2...1335ec32c1accc5398623b42389e59aac179fb2e 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 Dec 13 14:24:23 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Wed, 13 Dec 2023 09:24:23 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/24254 Message-ID: <6579be971307b_2e72b312384c6422@gitlab.mail> Finley McIlwaine pushed new branch wip/24254 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24254 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 Dec 13 14:26:38 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 13 Dec 2023 09:26:38 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 14 commits: AArch64: Fix broken conditional jumps for offsets >= 1MB Message-ID: <6579bf1e36ebc_2e72b3349c34644aa@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 9c77117a by Andreas Klebinger at 2023-12-13T19:56:26+05:30 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 (cherry picked from commit 2adc050857a9c1b992040fbfd55fbe65b2851b19) - - - - - 504267c8 by Ben Gamari at 2023-12-13T19:56:26+05:30 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. (cherry picked from commit f6b2751f58df5f4f83caa7a7ca56e66659d02b09) - - - - - a7c376b3 by Ben Gamari at 2023-12-13T19:56:26+05:30 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. (cherry picked from commit 8f6010b98f560200997a9d84a4e07bfd0ad6e496) - - - - - 4a59554a by Sylvain Henry at 2023-12-13T19:56:26+05:30 Rts: expose rtsOutOfBoundsAccess symbol (cherry picked from commit cbe4400d2690104053ec544cf7d0a9a13ee914ee) - - - - - 0cbe2812 by Sylvain Henry at 2023-12-13T19:56:26+05:30 Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066) bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a". (cherry picked from commit fe0675770b66a9ed393884d96e276b8d116fa2a2) - - - - - 51180e41 by Sylvain Henry at 2023-12-13T19:56:26+05:30 Bignum: fix right shift of negative BigNat with native backend (cherry picked from commit cc1625b1ffbdf086b8380bacd35abc8d85861637) - - - - - 4284c62e by Sylvain Henry at 2023-12-13T19:56:26+05:30 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. (cherry picked from commit 72c7380cb780933825bc84924908e01ce0495dc4) - - - - - 4e3cc493 by Moritz Angermann at 2023-12-13T19:56:26+05:30 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. (cherry picked from commit dafc47091c9107dcf81e1e80a105f59211927c89) (cherry picked from commit 8e7a2065e433aa56552b335d420b5bf925082078) - - - - - f08d756d by Moritz Angermann at 2023-12-13T19:56:26+05:30 [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. (cherry picked from commit df81536f2e53abf521a05eb1e482a076f5849c21) - - - - - b1f3b124 by Moritz Angermann at 2023-12-13T19:56:26+05:30 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" | ^ (cherry picked from commit e99cf237f84db34be0468a893b10394d6b364bce) - - - - - 96fedad6 by Ilias Tsitsimpis at 2023-12-13T19:56:26+05:30 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 (cherry picked from commit 257c2807587624592813a42e06a05c5fc34cb38c) (cherry picked from commit b2a03315f6336e2708ff54689f2241eb38198dd5) - - - - - e076fe50 by Moritz Angermann at 2023-12-13T19:56:26+05:30 [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. (cherry picked from commit 34f06334025521c2440ebedb0237697fbcc3c6de) - - - - - a0236d60 by Claudio Bley at 2023-12-13T19:56:26+05:30 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 (cherry picked from commit d561073727186c7b456c9ef113ccb7fc0df4560e) - - - - - 8fe78c40 by Zubin Duggal at 2023-12-13T19:56:26+05:30 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 (cherry picked from commit 8db8d2fd1c881032b1b360c032b6d9d072c11723) - - - - - 30 changed files: - 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/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/PPC/Instr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/X86.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/StgToCmm/CgUtils.hs - ghc/GHCi/UI.hs - hadrian/doc/flavours.md - hadrian/src/Settings/Flavours/Validate.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs - libraries/ghc-bignum/src/GHC/Num/BigNat.hs - m4/find_ld.m4 - rts/RtsMessages.c - rts/RtsSymbols.c - rts/include/rts/Messages.h - rts/linker/PEi386.c - rts/sm/NonMoving.h - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1335ec32c1accc5398623b42389e59aac179fb2e...8fe78c4039b7080246f183cda4ee89cc9599ff64 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1335ec32c1accc5398623b42389e59aac179fb2e...8fe78c4039b7080246f183cda4ee89cc9599ff64 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 Dec 13 14:50:21 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Wed, 13 Dec 2023 09:50:21 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 14 commits: AArch64: Fix broken conditional jumps for offsets >= 1MB Message-ID: <6579c4ad9a5a7_2e72b31796847125e@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: b71b053e by Andreas Klebinger at 2023-12-13T20:20:02+05:30 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 (cherry picked from commit 2adc050857a9c1b992040fbfd55fbe65b2851b19) - - - - - fc6e4003 by Ben Gamari at 2023-12-13T20:20:02+05:30 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. (cherry picked from commit f6b2751f58df5f4f83caa7a7ca56e66659d02b09) - - - - - d1f94ba7 by Ben Gamari at 2023-12-13T20:20:02+05:30 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. (cherry picked from commit 8f6010b98f560200997a9d84a4e07bfd0ad6e496) - - - - - 7a51125d by Sylvain Henry at 2023-12-13T20:20:02+05:30 Rts: expose rtsOutOfBoundsAccess symbol (cherry picked from commit cbe4400d2690104053ec544cf7d0a9a13ee914ee) - - - - - 9283b7d3 by Sylvain Henry at 2023-12-13T20:20:02+05:30 Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066) bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a". (cherry picked from commit fe0675770b66a9ed393884d96e276b8d116fa2a2) - - - - - c284a3e8 by Sylvain Henry at 2023-12-13T20:20:02+05:30 Bignum: fix right shift of negative BigNat with native backend (cherry picked from commit cc1625b1ffbdf086b8380bacd35abc8d85861637) - - - - - d5de8a2a by Sylvain Henry at 2023-12-13T20:20:02+05:30 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. (cherry picked from commit 72c7380cb780933825bc84924908e01ce0495dc4) - - - - - 83775ebb by Moritz Angermann at 2023-12-13T20:20:02+05:30 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. (cherry picked from commit dafc47091c9107dcf81e1e80a105f59211927c89) (cherry picked from commit 8e7a2065e433aa56552b335d420b5bf925082078) - - - - - ab7bc679 by Moritz Angermann at 2023-12-13T20:20:02+05:30 [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. (cherry picked from commit df81536f2e53abf521a05eb1e482a076f5849c21) - - - - - d35f5d1a by Moritz Angermann at 2023-12-13T20:20:02+05:30 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" | ^ (cherry picked from commit e99cf237f84db34be0468a893b10394d6b364bce) - - - - - 54617f3b by Ilias Tsitsimpis at 2023-12-13T20:20:02+05:30 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 (cherry picked from commit 257c2807587624592813a42e06a05c5fc34cb38c) (cherry picked from commit b2a03315f6336e2708ff54689f2241eb38198dd5) - - - - - f9ff2f06 by Moritz Angermann at 2023-12-13T20:20:02+05:30 [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. (cherry picked from commit 34f06334025521c2440ebedb0237697fbcc3c6de) - - - - - 9397af86 by Claudio Bley at 2023-12-13T20:20:02+05:30 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 (cherry picked from commit d561073727186c7b456c9ef113ccb7fc0df4560e) - - - - - aee7728a by Zubin Duggal at 2023-12-13T20:20:02+05:30 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 (cherry picked from commit 8db8d2fd1c881032b1b360c032b6d9d072c11723) - - - - - 30 changed files: - 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/BlockLayout.hs - compiler/GHC/CmmToAsm/Monad.hs - compiler/GHC/CmmToAsm/PPC/Instr.hs - compiler/GHC/CmmToAsm/Ppr.hs - compiler/GHC/CmmToAsm/X86.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/StgToCmm/CgUtils.hs - ghc/GHCi/UI.hs - hadrian/doc/flavours.md - hadrian/src/Settings/Flavours/Validate.hs - hadrian/src/Settings/Packages.hs - libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs - libraries/ghc-bignum/src/GHC/Num/BigNat.hs - m4/find_ld.m4 - rts/RtsMessages.c - rts/RtsSymbols.c - rts/include/rts/Messages.h - rts/linker/PEi386.c - rts/sm/NonMoving.h - + testsuite/tests/driver/T24196/T24196.stderr - + testsuite/tests/driver/T24196/T24196A.hs - + testsuite/tests/driver/T24196/T24196A.hs-boot - + testsuite/tests/driver/T24196/T24196B.hs - + testsuite/tests/driver/T24196/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8fe78c4039b7080246f183cda4ee89cc9599ff64...aee7728acd04eecf12f1e3411dfb50e4e86b33eb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8fe78c4039b7080246f183cda4ee89cc9599ff64...aee7728acd04eecf12f1e3411dfb50e4e86b33eb 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 Dec 13 15:11:32 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Wed, 13 Dec 2023 10:11:32 -0500 Subject: [Git][ghc/ghc][wip/24254] 2 commits: add test for late plugins Message-ID: <6579c9a49eb65_2e72b318c781872250@gitlab.mail> Finley McIlwaine pushed to branch wip/24254 at Glasgow Haskell Compiler / GHC Commits: f4fe234b by Finley McIlwaine at 2023-12-13T07:11:01-08:00 add test for late plugins - - - - - 14e6fd8b by Finley McIlwaine at 2023-12-13T07:11:14-08:00 Document late plugins - - - - - 6 changed files: - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -54,6 +54,9 @@ Compiler - Defaulting plugins can now propose solutions to entangled sets of type variables. This allows defaulting of multi-parameter type classes. See :ghc-ticket:`23832`. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,57 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different than typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding``, it will change its value to the ``Int`` expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,49 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e94ec1a817dcb157128c708e2ef4c90c24611928...14e6fd8b492c331e1a1db22d174e1ae4f3101979 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e94ec1a817dcb157128c708e2ef4c90c24611928...14e6fd8b492c331e1a1db22d174e1ae4f3101979 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 Dec 13 15:15:07 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Wed, 13 Dec 2023 10:15:07 -0500 Subject: [Git][ghc/ghc][wip/24254] 257 commits: Simplify and correct nasty case in coercion opt Message-ID: <6579ca7bca9cf_2e72b31c02af0756a3@gitlab.mail> Finley McIlwaine pushed to branch wip/24254 at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 746c0b25 by Finley McIlwaine at 2023-12-13T07:14:37-08:00 Late plugins - - - - - a5b83726 by Finley McIlwaine at 2023-12-13T07:14:37-08:00 withTiming on LateCCs and late plugins - - - - - 1cd642c0 by Finley McIlwaine at 2023-12-13T07:14:37-08:00 add test for late plugins - - - - - 896bde24 by Finley McIlwaine at 2023-12-13T07:14:55-08:00 Document late plugins - - - - - 30 changed files: - .ghcid - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/merge_request_templates/Default.md - .gitlab/rel_eng/upload.sh - .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/Lexer.x - compiler/GHC/CmmToAsm.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/AArch64/Regs.hs - compiler/GHC/CmmToAsm/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/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/FamInstEnv.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14e6fd8b492c331e1a1db22d174e1ae4f3101979...896bde2463b8cc79fe148319d0722b4c071772b1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/14e6fd8b492c331e1a1db22d174e1ae4f3101979...896bde2463b8cc79fe148319d0722b4c071772b1 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 Dec 13 16:23:04 2023 From: gitlab at gitlab.haskell.org (Simon Peyton Jones (@simonpj)) Date: Wed, 13 Dec 2023 11:23:04 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24251 Message-ID: <6579da682b73d_2e72b33185c6077875@gitlab.mail> Simon Peyton Jones pushed new branch wip/T24251 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24251 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 Dec 13 16:34:03 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 11:34:03 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/ipe-length Message-ID: <6579dcfb8f8c6_2e72b3317881c82841@gitlab.mail> Ben Gamari pushed new branch wip/ipe-length at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ipe-length 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 Dec 13 16:56:52 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 11:56:52 -0500 Subject: [Git][ghc/ghc][wip/ipe-length] 2 commits: rts/EventLog: Place eliminate duplicate strlens Message-ID: <6579e254a22ae_2e72b33393160881fe@gitlab.mail> Ben Gamari pushed to branch wip/ipe-length at Glasgow Haskell Compiler / GHC Commits: c350df3c by Ben Gamari at 2023-12-13T11:56:41-05:00 rts/EventLog: Place eliminate duplicate strlens Previously many of the `post*` implementations would first compute the length of the event's strings in order to determine the event length. Later we would then end up computing the length yet again in `postString`. Now we instead pass the string length to `postStringLen`, avoiding the repeated work. - - - - - 9340d998 by Ben Gamari at 2023-12-13T11:56:41-05:00 rts/eventlog: Place upper bound on IPE string field lengths The strings in IPE events may be of unbounded length. Limit the lengths of these fields to 64k characters to ensure that we don't exceed the maximum event length. - - - - - 1 changed file: - rts/eventlog/EventLog.c Changes: ===================================== rts/eventlog/EventLog.c ===================================== @@ -27,6 +27,8 @@ #include #endif +#define MIN(x,y) ((x) < (y) ? (x) : (y)) + Mutex state_change_mutex; bool eventlog_enabled; // protected by state_change_mutex to ensure // serialisation of calls to @@ -85,6 +87,14 @@ bool eventlog_enabled; // protected by state_change_mutex to ensure * case is that we must ensure that the buffers of any disabled capabilities are * flushed, lest their events are stuck in limbo. This is achieved with a call to * flushLocalEventsBuf in traceCapDisable. + * + * + * Note [Maximum event length] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * The maximum length of an eventlog event is determined by the maximum event + * buffer size, EVENT_LOG_SIZE. We must ensure that no variable-length event + * exceeds this limit. For this reason we impose maximum length limits on + * fields which may have unbounded values. */ static const EventLogWriter *event_log_writer = NULL; @@ -93,6 +103,7 @@ static const EventLogWriter *event_log_writer = NULL; // eventlog is restarted static eventlog_init_func_t *eventlog_header_funcs = NULL; +// See Note [Maximum event length] #define EVENT_LOG_SIZE 2 * (1024 * 1024) // 2MB static int flushCount = 0; @@ -172,14 +183,13 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size) eb->pos += size; } -/* Post a null-terminated string to the event log. - * It is the caller's responsibility to ensure that there is - * enough room for strlen(buf)+1 bytes. +/* Post a null-terminated string up to a given length to the event log. It is + * the caller's responsibility to ensure that there is enough room for + * len+1 bytes. */ -static inline void postString(EventsBuf *eb, const char *buf) +static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len) { if (buf) { - const int len = strlen(buf); ASSERT(eb->begin + eb->size > eb->pos + len + 1); memcpy(eb->pos, buf, len); eb->pos += len; @@ -188,6 +198,16 @@ static inline void postString(EventsBuf *eb, const char *buf) eb->pos++; } +/* Post a null-terminated string to the event log. + * It is the caller's responsibility to ensure that there is + * enough room for strlen(buf)+1 bytes. + */ +static inline void postString(EventsBuf *eb, const char *buf) +{ + const StgWord len = buf ? strlen(buf) : 0; + postStringLen(eb, buf, len); +} + static inline StgWord64 time_ns(void) { return TimeToNS(stat_getElapsedTime()); } @@ -1226,13 +1246,13 @@ void postHeapProfBegin(StgWord8 profile_id) postWord8(&eventBuf, profile_id); postWord64(&eventBuf, TimeToNS(flags->heapProfileInterval)); postWord32(&eventBuf, getHeapProfBreakdown()); - postString(&eventBuf, flags->modSelector); - postString(&eventBuf, flags->descrSelector); - postString(&eventBuf, flags->typeSelector); - postString(&eventBuf, flags->ccSelector); - postString(&eventBuf, flags->ccsSelector); - postString(&eventBuf, flags->retainerSelector); - postString(&eventBuf, flags->bioSelector); + postStringLen(&eventBuf, flags->modSelector, modSelector_len); + postStringLen(&eventBuf, flags->descrSelector, descrSelector_len); + postStringLen(&eventBuf, flags->typeSelector, typeSelector_len); + postStringLen(&eventBuf, flags->ccSelector, ccSelector_len); + postStringLen(&eventBuf, flags->ccsSelector, ccsSelector_len); + postStringLen(&eventBuf, flags->retainerSelector, retainerSelector_len); + postStringLen(&eventBuf, flags->bioSelector, bioSelector_len); RELEASE_LOCK(&eventBufMutex); } @@ -1277,7 +1297,7 @@ void postHeapProfSampleString(StgWord8 profile_id, postPayloadSize(&eventBuf, len); postWord8(&eventBuf, profile_id); postWord64(&eventBuf, residency); - postString(&eventBuf, label); + postStringLen(&eventBuf, label, label_len); RELEASE_LOCK(&eventBufMutex); } @@ -1297,9 +1317,9 @@ void postHeapProfCostCentre(StgWord32 ccID, postEventHeader(&eventBuf, EVENT_HEAP_PROF_COST_CENTRE); postPayloadSize(&eventBuf, len); postWord32(&eventBuf, ccID); - postString(&eventBuf, label); - postString(&eventBuf, module); - postString(&eventBuf, srcloc); + postStringLen(&eventBuf, label, label_len); + postStringLen(&eventBuf, module, module_len); + postStringLen(&eventBuf, srcloc, srcloc_len); postWord8(&eventBuf, is_caf); RELEASE_LOCK(&eventBufMutex); } @@ -1371,17 +1391,20 @@ void postProfBegin(void) #if defined(TICKY_TICKY) static void postTickyCounterDef(EventsBuf *eb, StgEntCounter *p) { - StgWord len = 8 + 2 + strlen(p->arg_kinds)+1 + strlen(p->str)+1 + 8 + strlen(p->ticky_json)+1; + StgWord arg_kinds_len = strlen(p->arg_kinds); + StgWord str_len = strlen(p->str); + StgWord ticky_json_len = strlen(p->ticky_json); + StgWord len = 8 + 2 + arg_kinds_len+1 + str_len+1 + 8 + ticky_json_len+1; CHECK(!ensureRoomForVariableEvent(eb, len)); postEventHeader(eb, EVENT_TICKY_COUNTER_DEF); postPayloadSize(eb, len); postWord64(eb, (uint64_t)((uintptr_t) p)); postWord16(eb, (uint16_t) p->arity); - postString(eb, p->arg_kinds); - postString(eb, p->str); + postStringLen(eb, p->arg_kinds, arg_kinds_len); + postStringLen(eb, p->str, str_len); postWord64(eb, (W_) (INFO_PTR_TO_STRUCT(p->info))); - postString(eb, p->ticky_json); + postStringLen(eb, p->ticky_json, ticky_json_len); } @@ -1426,14 +1449,16 @@ void postTickyCounterSamples(StgEntCounter *counters) #endif /* TICKY_TICKY */ void postIPE(const InfoProvEnt *ipe) { + // See Note [Maximum event length]. + const StgWord MAX_IPE_STRING_LEN = 65535; ACQUIRE_LOCK(&eventBufMutex); - StgWord table_name_len = strlen(ipe->prov.table_name); - StgWord closure_desc_len = strlen(ipe->prov.closure_desc); - StgWord ty_desc_len = strlen(ipe->prov.ty_desc); - StgWord label_len = strlen(ipe->prov.label); - StgWord module_len = strlen(ipe->prov.module); - StgWord src_file_len = strlen(ipe->prov.src_file); - StgWord src_span_len = strlen(ipe->prov.src_span); + StgWord table_name_len = MIN(strlen(ipe->prov.table_name), MAX_IPE_STRING_LEN); + StgWord closure_desc_len = MIN(strlen(ipe->prov.closure_desc), MAX_IPE_STRING_LEN); + StgWord ty_desc_len = MIN(strlen(ipe->prov.ty_desc), MAX_IPE_STRING_LEN); + StgWord label_len = MIN(strlen(ipe->prov.label), MAX_IPE_STRING_LEN); + StgWord module_len = MIN(strlen(ipe->prov.module), MAX_IPE_STRING_LEN); + StgWord src_file_len = MIN(strlen(ipe->prov.src_file), MAX_IPE_STRING_LEN); + StgWord src_span_len = MIN(strlen(ipe->prov.src_span), MAX_IPE_STRING_LEN); // 8 for the info word // 1 null after each string @@ -1443,17 +1468,17 @@ void postIPE(const InfoProvEnt *ipe) postEventHeader(&eventBuf, EVENT_IPE); postPayloadSize(&eventBuf, len); postWord64(&eventBuf, (StgWord) INFO_PTR_TO_STRUCT(ipe->info)); - postString(&eventBuf, ipe->prov.table_name); - postString(&eventBuf, ipe->prov.closure_desc); - postString(&eventBuf, ipe->prov.ty_desc); - postString(&eventBuf, ipe->prov.label); - postString(&eventBuf, ipe->prov.module); + postStringLen(&eventBuf, ipe->prov.table_name, table_name_len); + postStringLen(&eventBuf, ipe->prov.closure_desc, closure_desc_len); + postStringLen(&eventBuf, ipe->prov.ty_desc, ty_desc_len); + postStringLen(&eventBuf, ipe->prov.label, label_len); + postStringLen(&eventBuf, ipe->prov.module, module_len); // Manually construct the location field: ":\0" postBuf(&eventBuf, (const StgWord8*) ipe->prov.src_file, src_file_len); StgWord8 colon = ':'; postBuf(&eventBuf, &colon, 1); - postString(&eventBuf, ipe->prov.src_span); + postStringLen(&eventBuf, ipe->prov.src_span, src_span_len); RELEASE_LOCK(&eventBufMutex); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/498135806715b8c5b775dd468e48a887957c61e2...9340d9987abe2ebf7f66659ffc48a822586f6edd -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/498135806715b8c5b775dd468e48a887957c61e2...9340d9987abe2ebf7f66659ffc48a822586f6edd 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 Dec 13 17:11:54 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:11:54 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/tsan/fix-thunk-update Message-ID: <6579e5da4c4bb_2e72b34b20c109025b@gitlab.mail> Ben Gamari pushed new branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/tsan/fix-thunk-update 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 Dec 13 17:14:34 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:14:34 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <6579e67a9b1a4_2e72b34af32d89045c@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: fa63b590 by Ben Gamari at 2023-12-13T12:14:14-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. - - - - - 19 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -311,7 +311,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +326,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa63b5902389aa929af5ec04b93b601fd456633f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa63b5902389aa929af5ec04b93b601fd456633f 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 Dec 13 17:16:54 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:16:54 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 329 commits: compiler, ghci: error codes link to HF error index Message-ID: <6579e70627a67_2e72b34ae8edc90979@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - fa63b590 by Ben Gamari at 2023-12-13T12:14:14-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. - - - - - 637d5682 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - 025f8002 by Ben Gamari at 2023-12-13T12:14:41-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - 322b8e37 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Silence spurious data races in ticky counters Previously we would use non-atomic accesses when bumping ticky counters, which would result in spurious data race reports from ThreadSanitizer when the threaded RTS was in use. - - - - - f46a10d7 by Ben Gamari at 2023-12-13T12:14:41-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 5e06b4d6 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix data race in Interpreter's preemption check - - - - - 300ca672 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix data race in threadStatus# - - - - - 3f42d9dc by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix data race in CHECK_GC - - - - - 0b8d0988 by Ben Gamari at 2023-12-13T12:14:41-05:00 base: use atomic write when updating timer manager - - - - - c5605e0f by Ben Gamari at 2023-12-13T12:14:41-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - cce8619e by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - b8f229a0 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix synchronization on thread blocking state - - - - - d875eef9 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 45d63c85 by Ben Gamari at 2023-12-13T12:14:41-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 0cadb146 by Ben Gamari at 2023-12-13T12:14:41-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - eac4bda3 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts/Messages: Fix data race - - - - - 98254e75 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts/Prof: Fix data race - - - - - ee1933ab by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - 99086ce0 by Ben Gamari at 2023-12-13T12:14:41-05:00 rts: Fix data races in profiling timer - - - - - 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/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/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Pipeline.hs - compiler/GHC/Cmm/ThreadSanitizer.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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e859cda5ba9fbc48c1dfe3e278944dd666f8bc3...99086ce046f00a2773a8ff02b93623f6f1f37d7c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e859cda5ba9fbc48c1dfe3e278944dd666f8bc3...99086ce046f00a2773a8ff02b93623f6f1f37d7c 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 Dec 13 17:27:53 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:27:53 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/tsan/fix-thunk-update-9.6 Message-ID: <6579e999b4af0_2e72b34fbcd8c959c3@gitlab.mail> Ben Gamari pushed new branch wip/tsan/fix-thunk-update-9.6 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/tsan/fix-thunk-update-9.6 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 Dec 13 17:42:50 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:42:50 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update-9.6] Fix thunk update ordering Message-ID: <6579ed1ac882a_2e72b35aaa67c97696@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update-9.6 at Glasgow Haskell Compiler / GHC Commits: a9489a22 by Ben Gamari at 2023-12-13T12:42:34-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. (cherry picked from commit fa63b5902389aa929af5ec04b93b601fd456633f) - - - - - 18 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -701,10 +701,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) [node, CmmReg (CmmGlobal EagerBlackholeInfo)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal EagerBlackholeInfo)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1767,7 +1767,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1835,7 +1835,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1937,7 +1937,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2026,7 +2026,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2307,7 +2307,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -509,7 +509,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE; + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -517,7 +519,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -527,7 +532,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -661,6 +669,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE; jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -59,8 +59,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; @@ -76,9 +76,9 @@ INLINE_HEADER void updateWithIndirection (Capability *cap, /* See Note [Heap memory barriers] in SMP.h */ bdescr *bd = Bdescr((StgPtr)p1); if (bd->gen_no != 0) { - IF_NONMOVING_WRITE_BARRIER_ENABLED { - updateRemembSetPushThunk(cap, (StgThunk*)p1); - } + IF_NONMOVING_WRITE_BARRIER_ENABLED { + updateRemembSetPushThunk(cap, (StgThunk*)p1); + } recordMutableCap(p1, cap, bd->gen_no); TICK_UPD_OLD_IND(); } else { ===================================== rts/include/Cmm.h ===================================== @@ -309,7 +309,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -324,7 +324,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ ===================================== rts/sm/Evac.c ===================================== @@ -1543,7 +1543,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -569,8 +569,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -785,7 +785,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9489a220c7ad78599f96bf03d9b1b73d82cba14 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9489a220c7ad78599f96bf03d9b1b73d82cba14 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 Dec 13 17:53:32 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 12:53:32 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update-9.6] Fix thunk update ordering Message-ID: <6579ef9caf478_2e72b35e3a774100830@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update-9.6 at Glasgow Haskell Compiler / GHC Commits: fcfb0850 by Ben Gamari at 2023-12-13T12:53:12-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. (cherry picked from commit fa63b5902389aa929af5ec04b93b601fd456633f) - - - - - 17 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -701,10 +701,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) [node, CmmReg (CmmGlobal EagerBlackholeInfo)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal EagerBlackholeInfo)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1767,7 +1767,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1835,7 +1835,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1937,7 +1937,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2026,7 +2026,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2307,7 +2307,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -509,7 +509,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE; + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -517,7 +519,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -527,7 +532,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -661,6 +669,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE; jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -59,8 +59,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; @@ -76,9 +76,9 @@ INLINE_HEADER void updateWithIndirection (Capability *cap, /* See Note [Heap memory barriers] in SMP.h */ bdescr *bd = Bdescr((StgPtr)p1); if (bd->gen_no != 0) { - IF_NONMOVING_WRITE_BARRIER_ENABLED { - updateRemembSetPushThunk(cap, (StgThunk*)p1); - } + IF_NONMOVING_WRITE_BARRIER_ENABLED { + updateRemembSetPushThunk(cap, (StgThunk*)p1); + } recordMutableCap(p1, cap, bd->gen_no); TICK_UPD_OLD_IND(); } else { ===================================== rts/include/Cmm.h ===================================== @@ -309,7 +309,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -324,7 +324,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } ===================================== rts/sm/Storage.c ===================================== @@ -569,8 +569,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -785,7 +785,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcfb0850d1960b677a2f6b9bdf45d8ccef169aeb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fcfb0850d1960b677a2f6b9bdf45d8ccef169aeb 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 Dec 13 17:54:49 2023 From: gitlab at gitlab.haskell.org (Vladislav Zavialov (@int-index)) Date: Wed, 13 Dec 2023 12:54:49 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/int-index/link-ghc-experimental Message-ID: <6579efe927200_2e72b35e3a774101226@gitlab.mail> Vladislav Zavialov pushed new branch wip/int-index/link-ghc-experimental at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/link-ghc-experimental 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 Dec 13 20:49:27 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 15:49:27 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657a18d7811e1_2e72b3a48b87c120167@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: a589b899 by Ben Gamari at 2023-12-13T15:49:09-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. - - - - - 19 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld![(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld![(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif @@ -707,7 +720,7 @@ -------------------------------------------------------------------------- */ #if defined(TICKY_TICKY) -#define TICK_BUMP_BY(ctr,n) W_[ctr] = W_[ctr] + n +#define TICK_BUMP_BY(ctr,n) %relaxed W_[ctr] = W_![ctr] + n #else #define TICK_BUMP_BY(ctr,n) /* nothing */ #endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a589b899e072c4e0db9dbd3d9089fabb5a3d7aa7 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a589b899e072c4e0db9dbd3d9089fabb5a3d7aa7 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 Dec 13 20:52:15 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 15:52:15 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657a197f41287_2e72b3a5b29a81209f6@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: 0f4a6a78 by Ben Gamari at 2023-12-13T15:51:57-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. - - - - - 20 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/rts/TSANUtils.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld![(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld![(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif @@ -707,7 +720,7 @@ -------------------------------------------------------------------------- */ #if defined(TICKY_TICKY) -#define TICK_BUMP_BY(ctr,n) W_[ctr] = W_[ctr] + n +#define TICK_BUMP_BY(ctr,n) %relaxed W_[ctr] = W_![ctr] + n #else #define TICK_BUMP_BY(ctr,n) /* nothing */ #endif ===================================== rts/include/rts/TSANUtils.h ===================================== @@ -78,6 +78,8 @@ #error TSAN cannot be enabled without C11 atomics support. #endif +#if !defined(CMINUSMINUS) + #define TSAN_ANNOTATE_HAPPENS_BEFORE(addr) \ AnnotateHappensBefore(__FILE__, __LINE__, (void*)(addr)) #define TSAN_ANNOTATE_HAPPENS_AFTER(addr) \ @@ -106,3 +108,4 @@ uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, ui uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); +#endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f4a6a781e6166baf5bb5d1a8bf152e2811e57f9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f4a6a781e6166baf5bb5d1a8bf152e2811e57f9 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 Dec 13 20:52:50 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 15:52:50 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 17 commits: Fix thunk update ordering Message-ID: <657a19a24773b_2e72b3a6073541215a1@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 0f4a6a78 by Ben Gamari at 2023-12-13T15:51:57-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. - - - - - 3deee773 by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - d9e4e569 by Ben Gamari at 2023-12-13T15:52:32-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - 2ffe9a3f by Ben Gamari at 2023-12-13T15:52:32-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 72bdc56e by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Fix data race in Interpreter's preemption check - - - - - e8698a79 by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Fix data race in threadStatus# - - - - - 9a148b32 by Ben Gamari at 2023-12-13T15:52:32-05:00 base: use atomic write when updating timer manager - - - - - d86ea6c5 by Ben Gamari at 2023-12-13T15:52:32-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - 0fb2803e by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - 4ef48b3b by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Fix synchronization on thread blocking state - - - - - 521e76af by Ben Gamari at 2023-12-13T15:52:32-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 7180e2ee by Ben Gamari at 2023-12-13T15:52:33-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 187d013f by Ben Gamari at 2023-12-13T15:52:33-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 19a5b0ac by Ben Gamari at 2023-12-13T15:52:33-05:00 rts/Messages: Fix data race - - - - - bf0d9842 by Ben Gamari at 2023-12-13T15:52:33-05:00 rts/Prof: Fix data race - - - - - f5161b9e by Ben Gamari at 2023-12-13T15:52:33-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - fa8aca8e by Ben Gamari at 2023-12-13T15:52:33-05:00 rts: Fix data races in profiling timer - - - - - 30 changed files: - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/base/src/GHC/Event/Thread.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Exception.cmm - rts/Heap.c - rts/HeapStackCheck.cmm - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99086ce046f00a2773a8ff02b93623f6f1f37d7c...fa8aca8e0304056d9a1139da0de450eb2fc6be68 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/99086ce046f00a2773a8ff02b93623f6f1f37d7c...fa8aca8e0304056d9a1139da0de450eb2fc6be68 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 Dec 13 21:03:07 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:03:07 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657a1c0b9a500_2e72b3ac1a7781222ef@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: f0682cb3 by Ben Gamari at 2023-12-13T16:02:24-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. - - - - - 20 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/rts/TSANUtils.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld![(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld![(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif ===================================== rts/include/rts/TSANUtils.h ===================================== @@ -78,6 +78,8 @@ #error TSAN cannot be enabled without C11 atomics support. #endif +#if !defined(CMINUSMINUS) + #define TSAN_ANNOTATE_HAPPENS_BEFORE(addr) \ AnnotateHappensBefore(__FILE__, __LINE__, (void*)(addr)) #define TSAN_ANNOTATE_HAPPENS_AFTER(addr) \ @@ -106,3 +108,4 @@ uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, ui uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); +#endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0682cb33419e7ae3f70d28fd8fd0d651cb1376e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0682cb33419e7ae3f70d28fd8fd0d651cb1376e 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 Dec 13 21:04:06 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:04:06 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 17 commits: Fix thunk update ordering Message-ID: <657a1c4631e3e_2e72b3ad4ec0c122861@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: f0682cb3 by Ben Gamari at 2023-12-13T16:02:24-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. - - - - - 2763aa7a by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - 6d23ae25 by Ben Gamari at 2023-12-13T16:03:55-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - 301f14fd by Ben Gamari at 2023-12-13T16:03:55-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 0a72f699 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Fix data race in Interpreter's preemption check - - - - - 52b8d632 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Fix data race in threadStatus# - - - - - 2a31080f by Ben Gamari at 2023-12-13T16:03:55-05:00 base: use atomic write when updating timer manager - - - - - bcbebfac by Ben Gamari at 2023-12-13T16:03:55-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - 89050edf by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - 7aa56933 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Fix synchronization on thread blocking state - - - - - 2595b0d9 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 4f888bb5 by Ben Gamari at 2023-12-13T16:03:55-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 843f3c3e by Ben Gamari at 2023-12-13T16:03:55-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - f9f8c846 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts/Messages: Fix data race - - - - - d6c509c7 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts/Prof: Fix data race - - - - - 39a6c2f9 by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - 849b8b0d by Ben Gamari at 2023-12-13T16:03:55-05:00 rts: Fix data races in profiling timer - - - - - 30 changed files: - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/base/src/GHC/Event/Thread.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Exception.cmm - rts/Heap.c - rts/HeapStackCheck.cmm - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa8aca8e0304056d9a1139da0de450eb2fc6be68...849b8b0de53f327d00479f994b816618423c5e40 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fa8aca8e0304056d9a1139da0de450eb2fc6be68...849b8b0de53f327d00479f994b816618423c5e40 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 Dec 13 21:13:02 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Wed, 13 Dec 2023 16:13:02 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Remove last EpAnn from extension points Message-ID: <657a1e5e3018_2e72b3aea2914123569@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: ad7a0bb4 by Alan Zimmerman at 2023-12-13T21:10:28+00:00 EPA: Remove last EpAnn from extension points - - - - - 30 changed files: - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.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/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Binds.hs ===================================== @@ -132,7 +132,7 @@ type instance XXHsBindsLR GhcPs pR = DataConCantHappen type instance XXHsBindsLR GhcRn pR = DataConCantHappen type instance XXHsBindsLR GhcTc pR = AbsBinds -type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn] +type instance XPSB (GhcPass idL) GhcPs = [AddEpAnn] type instance XPSB (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars] type instance XPSB (GhcPass idL) GhcTc = NameSet @@ -646,7 +646,7 @@ isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -- EPA annotations in GhcPs, dictionary Id in GhcTc -type instance XCIPBind GhcPs = EpAnn [AddEpAnn] +type instance XCIPBind GhcPs = [AddEpAnn] type instance XCIPBind GhcRn = NoExtField type instance XCIPBind GhcTc = Id type instance XXIPBind (GhcPass p) = DataConCantHappen ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -362,7 +362,7 @@ type instance XClassDecl GhcTc = NameSet -- FVs type instance XXTyClDecl (GhcPass _) = DataConCantHappen -type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] +type instance XCTyFamInstDecl (GhcPass _) = [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen ------------- Pretty printing FamilyDecls ----------- @@ -512,7 +512,7 @@ pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep -type instance XCFunDep (GhcPass _) = EpAnn [AddEpAnn] +type instance XCFunDep (GhcPass _) = [AddEpAnn] type instance XXFunDep (GhcPass _) = DataConCantHappen pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc @@ -546,7 +546,7 @@ type instance XCKindSig (GhcPass _) = NoExtField type instance XTyVarSig (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen -type instance XCFamilyDecl (GhcPass _) = EpAnn [AddEpAnn] +type instance XCFamilyDecl (GhcPass _) = [AddEpAnn] type instance XXFamilyDecl (GhcPass _) = DataConCantHappen @@ -573,7 +573,7 @@ resultVariableName _ = Nothing ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn (GhcPass _) = EpAnn [AddEpAnn] +type instance XCInjectivityAnn (GhcPass _) = [AddEpAnn] type instance XXInjectivityAnn (GhcPass _) = DataConCantHappen instance OutputableBndrId p @@ -620,7 +620,7 @@ instance OutputableBndrId p type instance XCHsDataDefn (GhcPass _) = NoExtField type instance XXHsDataDefn (GhcPass _) = DataConCantHappen -type instance XCHsDerivingClause (GhcPass _) = EpAnn [AddEpAnn] +type instance XCHsDerivingClause (GhcPass _) = [AddEpAnn] type instance XXHsDerivingClause (GhcPass _) = DataConCantHappen instance OutputableBndrId p @@ -665,11 +665,11 @@ type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT GhcPs = (EpUniToken "::" "∷", EpAnn [AddEpAnn]) +type instance XConDeclGADT GhcPs = (EpUniToken "::" "∷", [AddEpAnn]) type instance XConDeclGADT GhcRn = NoExtField type instance XConDeclGADT GhcTc = NoExtField -type instance XConDeclH98 GhcPs = EpAnn [AddEpAnn] +type instance XConDeclH98 GhcPs = [AddEpAnn] type instance XConDeclH98 GhcRn = NoExtField type instance XConDeclH98 GhcTc = NoExtField @@ -1047,15 +1047,15 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XStockStrategy GhcPs = EpAnn [AddEpAnn] +type instance XStockStrategy GhcPs = [AddEpAnn] type instance XStockStrategy GhcRn = NoExtField type instance XStockStrategy GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn] +type instance XAnyClassStrategy GhcPs = [AddEpAnn] type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy GhcPs = EpAnn [AddEpAnn] +type instance XNewtypeStrategy GhcPs = [AddEpAnn] type instance XNewtypeStrategy GhcRn = NoExtField type instance XNewtypeStrategy GhcTc = NoExtField @@ -1063,7 +1063,7 @@ type instance XViaStrategy GhcPs = XViaStrategyPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs) +data XViaStrategyPs = XViaStrategyPs [AddEpAnn] (LHsSigType GhcPs) instance OutputableBndrId p => Outputable (DerivStrategy (GhcPass p)) where @@ -1102,7 +1102,7 @@ mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds ************************************************************************ -} -type instance XCDefaultDecl GhcPs = EpAnn [AddEpAnn] +type instance XCDefaultDecl GhcPs = [AddEpAnn] type instance XCDefaultDecl GhcRn = NoExtField type instance XCDefaultDecl GhcTc = NoExtField @@ -1121,11 +1121,11 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XForeignImport GhcPs = EpAnn [AddEpAnn] +type instance XForeignImport GhcPs = [AddEpAnn] type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion -type instance XForeignExport GhcPs = EpAnn [AddEpAnn] +type instance XForeignExport GhcPs = [AddEpAnn] type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -430,7 +430,7 @@ instance NoAnn AnnsIf where type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen -type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel +type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen type instance XPresent (GhcPass _) = NoExtField @@ -1119,7 +1119,7 @@ instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ************************************************************************ -} -type instance XCmdArrApp GhcPs = EpAnn AddEpAnn +type instance XCmdArrApp GhcPs = AddEpAnn type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type @@ -1127,20 +1127,20 @@ type instance XCmdArrForm GhcPs = AnnList type instance XCmdArrForm GhcRn = NoExtField type instance XCmdArrForm GhcTc = NoExtField -type instance XCmdApp (GhcPass _) = EpAnnCO +type instance XCmdApp (GhcPass _) = NoExtField type instance XCmdLam (GhcPass _) = NoExtField type instance XCmdPar GhcPs = (EpToken "(", EpToken ")") type instance XCmdPar GhcRn = NoExtField type instance XCmdPar GhcTc = NoExtField -type instance XCmdCase GhcPs = EpAnn EpAnnHsCase +type instance XCmdCase GhcPs = EpAnnHsCase type instance XCmdCase GhcRn = NoExtField type instance XCmdCase GhcTc = NoExtField -type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn] +type instance XCmdLamCase (GhcPass _) = [AddEpAnn] -type instance XCmdIf GhcPs = EpAnn AnnsIf +type instance XCmdIf GhcPs = AnnsIf type instance XCmdIf GhcRn = NoExtField type instance XCmdIf GhcTc = NoExtField @@ -1148,7 +1148,7 @@ type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField -type instance XCmdDo GhcPs = EpAnn AnnList +type instance XCmdDo GhcPs = AnnList type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type @@ -1342,7 +1342,7 @@ data MatchGroupTc type instance XXMatchGroup (GhcPass _) b = DataConCantHappen -type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn] +type instance XCMatch (GhcPass _) b = [AddEpAnn] type instance XXMatch (GhcPass _) b = DataConCantHappen instance (OutputableBndrId pr, Outputable body) @@ -1513,7 +1513,7 @@ data RecStmtTc = type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField -type instance XBindStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] +type instance XBindStmt (GhcPass _) GhcPs b = [AddEpAnn] type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc @@ -1537,17 +1537,17 @@ type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt (GhcPass _) GhcTc b = Type -type instance XLetStmt (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn] +type instance XLetStmt (GhcPass _) (GhcPass _) b = [AddEpAnn] type instance XParStmt (GhcPass _) GhcPs b = NoExtField type instance XParStmt (GhcPass _) GhcRn b = NoExtField type instance XParStmt (GhcPass _) GhcTc b = Type -type instance XTransStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] +type instance XTransStmt (GhcPass _) GhcPs b = [AddEpAnn] type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type -type instance XRecStmt (GhcPass _) GhcPs b = EpAnn AnnList +type instance XRecStmt (GhcPass _) GhcPs b = AnnList type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -212,28 +212,28 @@ type instance XIEVar GhcTc = NoExtField -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingAbs GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn]) -type instance XIEThingAbs GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn]) -type instance XIEThingAbs GhcTc = EpAnn [AddEpAnn] +type instance XIEThingAbs GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn]) +type instance XIEThingAbs GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn]) +type instance XIEThingAbs GhcTc = [AddEpAnn] -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingAll GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn]) -type instance XIEThingAll GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn]) -type instance XIEThingAll GhcTc = EpAnn [AddEpAnn] +type instance XIEThingAll GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn]) +type instance XIEThingAll GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn]) +type instance XIEThingAll GhcTc = [AddEpAnn] -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn]) -type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), EpAnn [AddEpAnn]) -type instance XIEThingWith GhcTc = EpAnn [AddEpAnn] +type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn]) +type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn]) +type instance XIEThingWith GhcTc = [AddEpAnn] -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEModuleContents GhcPs = (Maybe (LWarningTxt GhcPs), EpAnn [AddEpAnn]) +type instance XIEModuleContents GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn]) type instance XIEModuleContents GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents GhcTc = NoExtField ===================================== compiler/GHC/Hs/Pat.hs ===================================== @@ -92,7 +92,7 @@ type instance XWildPat GhcTc = Type type instance XVarPat (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~' +type instance XLazyPat GhcPs = [AddEpAnn] -- For '~' type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField @@ -104,11 +104,11 @@ type instance XParPat GhcPs = (EpToken "(", EpToken ")") type instance XParPat GhcRn = NoExtField type instance XParPat GhcTc = NoExtField -type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' +type instance XBangPat GhcPs = [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = EpAnn AnnList +type instance XListPat GhcPs = AnnList -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField @@ -118,19 +118,19 @@ type instance XListPat GhcRn = NoExtField type instance XListPat GhcTc = Type -- List element type, for use in hsPatType. -type instance XTuplePat GhcPs = EpAnn [AddEpAnn] +type instance XTuplePat GhcPs = [AddEpAnn] type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn EpAnnSumPat +type instance XSumPat GhcPs = EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XConPat GhcPs = EpAnn [AddEpAnn] +type instance XConPat GhcPs = [AddEpAnn] type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn [AddEpAnn] +type instance XViewPat GhcPs = [AddEpAnn] type instance XViewPat GhcRn = Maybe (HsExpr GhcRn) -- The @HsExpr GhcRn@ gives an inverse to the view function. -- This is used for overloaded lists in particular. @@ -146,15 +146,15 @@ type instance XSplicePat GhcTc = DataConCantHappen type instance XLitPat (GhcPass _) = NoExtField -type instance XNPat GhcPs = EpAnn [AddEpAnn] -type instance XNPat GhcRn = EpAnn [AddEpAnn] +type instance XNPat GhcPs = [AddEpAnn] +type instance XNPat GhcRn = [AddEpAnn] type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+" +type instance XNPlusKPat GhcPs = EpaLocation -- Of the "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn [AddEpAnn] +type instance XSigPat GhcPs = [AddEpAnn] type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type @@ -179,7 +179,7 @@ type instance XConPatTyArg GhcPs = EpToken "@" type instance XConPatTyArg GhcRn = NoExtField type instance XConPatTyArg GhcTc = NoExtField -type instance XHsFieldBind _ = EpAnn [AddEpAnn] +type instance XHsFieldBind _ = [AddEpAnn] -- --------------------------------------------------------------------- ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -470,7 +470,7 @@ pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Le pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True) pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) -type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] +type instance XConDeclField (GhcPass _) = [AddEpAnn] type instance XXConDeclField (GhcPass _) = DataConCantHappen instance OutputableBndrId p ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -338,9 +338,9 @@ mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> AnnList -> HsExpr GhcPs -mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] +mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> [AddEpAnn] -> Pat GhcPs -mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation +mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpaLocation -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions @@ -349,7 +349,7 @@ mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) mkBodyStmt :: LocatedA (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs)) -mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) +mkPsBindStmt :: [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn)) @@ -373,7 +373,7 @@ mkRecStmt :: forall (idL :: Pass) bodyR. (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL) - => EpAnn AnnList + => AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) @@ -401,7 +401,7 @@ mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf mkHsIf c a b anns = HsIf anns c a b -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -409,17 +409,17 @@ mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr mkNPlusKPat id lit anns = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformByStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupUsingStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupByUsingStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt :: [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt anns = TransStmt { trS_ext = anns , trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] @@ -468,7 +468,7 @@ emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) +mkLetStmt :: [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds ------------------------------- @@ -846,7 +846,7 @@ mkVarBind var rhs = L (getLoc rhs) $ var_id = var, var_rhs = rhs } mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs - -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs + -> LPat GhcPs -> HsPatSynDir GhcPs -> [AddEpAnn] -> HsBind GhcPs mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb where psb = PSB{ psb_ext = anns ===================================== compiler/GHC/Parser.y ===================================== @@ -1022,7 +1022,7 @@ export :: { OrdList (LIE GhcPs) } ; return $ unitOL $ reLoc $ sL span $ impExp } } | maybe_warning_pragma 'module' modid {% do { let { span = (maybe comb2 comb3 $1) $2 $> ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 } - ; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3)) + ; locImpExp <- return (sL span (IEModuleContents ($1, [mj AnnModule $2]) $3)) ; return $ unitOL $ reLoc $ locImpExp } } | maybe_warning_pragma 'pattern' qcon { let span = (maybe comb2 comb3 $1) $2 $> in unitOL $ reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) } @@ -1193,7 +1193,7 @@ importlist1 :: { OrdList (LIE GhcPs) } import :: { OrdList (LIE GhcPs) } : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) } - | 'module' modid {% fmap (unitOL . reLoc) $ acs (\cs -> sLL $1 $> (IEModuleContents (Nothing, EpAnn (glEE $1 $>) [mj AnnModule $1] cs) $2)) } + | 'module' modid {% fmap (unitOL . reLoc) $ return (sLL $1 $> (IEModuleContents (Nothing, [mj AnnModule $1]) $2)) } | 'pattern' qcon { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) } ----------------------------------------------------------------------------- @@ -1254,9 +1254,9 @@ topdecl :: { LHsDecl GhcPs } | inst_decl { sL1a $1 (InstD noExtField (unLoc $1)) } | stand_alone_deriving { sL1a $1 (DerivD noExtField (unLoc $1)) } | role_annot { sL1a $1 (RoleAnnotD noExtField (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $> - (DefD noExtField (DefaultDecl (EpAnn (glEE $1 $>) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) } - | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glEE $1 $>) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) } + | 'default' '(' comma_types0 ')' {% amsA' (sLL $1 $> + (DefD noExtField (DefaultDecl [mj AnnDefault $1,mop $2,mcp $4] $3))) } + | 'foreign' fdecl {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) } | '{-# DEPRECATED' deprecations '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getDEPRECATED_PRAGs $1)) (fromOL $2))) } | '{-# WARNING' warnings '#-}' {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getWARNING_PRAGs $1)) (fromOL $2))) } | '{-# RULES' rules '#-}' {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ([mo $1,mc $3], (getRULES_PRAGs $1)) (reverse $2))) } @@ -1393,18 +1393,17 @@ overlap_pragma :: { Maybe (LocatedP OverlapMode) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } - : 'stock' {% acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) } - | 'anyclass' {% acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) } - | 'newtype' {% acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) } + : 'stock' {% amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) } + | 'anyclass' {% amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) } + | 'newtype' {% amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) } deriv_strategy_via :: { LDerivStrategy GhcPs } - : 'via' sigktype {% acsA (\cs -> sLL $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glEE $1 $>) [mj AnnVia $1] cs) - $2))) } + : 'via' sigktype {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs [mj AnnVia $1] $2))) } deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } - : 'stock' {% fmap Just $ acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) } - | 'anyclass' {% fmap Just $ acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) } - | 'newtype' {% fmap Just $ acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) } + : 'stock' {% fmap Just $ amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) } + | 'anyclass' {% fmap Just $ amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) } + | 'newtype' {% fmap Just $ amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) } | deriv_strategy_via { Just $1 } | {- empty -} { Nothing } @@ -1417,7 +1416,7 @@ opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) } injectivity_cond :: { LInjectivityAnn GhcPs } : tyvarid '->' inj_varids - {% acsA (\cs -> sLL $1 $> (InjectivityAnn (EpAnn (glR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) } + {% amsA' (sLL $1 $> (InjectivityAnn [mu AnnRarrow $2] $1 (reverse (unLoc $3)))) } inj_varids :: { Located [LocatedN RdrName] } : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } @@ -1657,21 +1656,21 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } pattern_synonym_decl :: { LHsDecl GhcPs } : 'pattern' pattern_synonym_lhs '=' pat {% let (name, args, as ) = $2 in - acsA (\cs -> sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 + amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 ImplicitBidirectional - (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) } + (as ++ [mj AnnPattern $1, mj AnnEqual $3])) } | 'pattern' pattern_synonym_lhs '<-' pat {% let (name, args, as) = $2 in - acsA (\cs -> sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional - (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) } + amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional + (as ++ [mj AnnPattern $1,mu AnnLarrow $3])) } | 'pattern' pattern_synonym_lhs '<-' pat where_decls {% do { let (name, args, as) = $2 ; mg <- mkPatSynMatchGroup name $5 - ; acsA (\cs -> sLL $1 $> . ValD noExtField $ + ; amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 (ExplicitBidirectional mg) - (EpAnn (glEE $1 $>) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) + (as ++ [mj AnnPattern $1,mu AnnLarrow $3])) }} pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) } @@ -2026,7 +2025,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (fst $ unLoc $2) (unLoc $1) + {% fmap unitOL $ amsA' (sLL $1 $> $ (Warning (fst $ unLoc $2) (unLoc $1) (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } strings :: { Located ([AddEpAnn],[Located StringLiteral]) } @@ -2051,19 +2050,19 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } -- Annotations annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> - acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation (AnnPragma (mo $1) (mc $4) [], (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> - acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation (AnnPragma (mo $1) (mc $5) [mj AnnType $2], (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> - acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation (AnnPragma (mo $1) (mc $4) [mj AnnModule $2], (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } @@ -2071,7 +2070,7 @@ annotation :: { LHsDecl GhcPs } ----------------------------------------------------------------------------- -- Foreign import and export declarations -fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) } +fdecl :: { Located ([AddEpAnn], [AddEpAnn] -> HsDecl GhcPs) } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } @@ -2361,8 +2360,8 @@ fds1 :: { Located [LHsFunDep GhcPs] } | fd { sL1 $1 [$1] } fd :: { LHsFunDep GhcPs } - : varids0 '->' varids0 {% acsA (\cs -> L (comb3 $1 $2 $3) - (FunDep (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) [mu AnnRarrow $2] cs) + : varids0 '->' varids0 {% amsA' (L (comb3 $1 $2 $3) + (FunDep [mu AnnRarrow $2] (reverse (unLoc $1)) (reverse (unLoc $3)))) } @@ -2460,17 +2459,16 @@ constrs1 :: { Located [LConDecl GhcPs] } constr :: { LConDecl GhcPs } : forall context '=>' constr_stuff - {% acsA (\cs -> let (con,details) = unLoc $4 in + {% amsA' (let (con,details) = unLoc $4 in (L (comb4 $1 $2 $3 $4) (mkConDeclH98 - (EpAnn (spanAsAnchor (comb4 $1 $2 $3 $4)) - (mu AnnDarrow $3:(fst $ unLoc $1)) cs) + (mu AnnDarrow $3:(fst $ unLoc $1)) con (snd $ unLoc $1) (Just $2) details))) } | forall constr_stuff - {% acsA (\cs -> let (con,details) = unLoc $2 in - (L (comb2 $1 $2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs) + {% amsA' (let (con,details) = unLoc $2 in + (L (comb2 $1 $2) (mkConDeclH98 (fst $ unLoc $1) con (snd $ unLoc $1) Nothing -- No context @@ -2498,8 +2496,8 @@ fielddecls1 :: { [LConDeclField GhcPs] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : sig_vars '::' ctype - {% acsA (\cs -> L (comb2 $1 $3) - (ConDeclField (EpAnn (glEE $1 $>) [mu AnnDcolon $2] cs) + {% amsA' (L (comb2 $1 $3) + (ConDeclField [mu AnnDcolon $2] (reverse (map (\ln@(L l n) -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))} @@ -2518,15 +2516,15 @@ derivings :: { Located (HsDeriving GhcPs) } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) Nothing $2) } + in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] Nothing $2) } | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) (Just $2) $3) } + in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $2) $3) } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glEE $1 $>) [mj AnnDeriving $1] cs) (Just $3) $2) } + in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $3) $2) } deriv_clause_types :: { LDerivClauseTys GhcPs } : qtycon { let { tc = sL1a $1 $ mkHsImplicitSigType $ @@ -2708,22 +2706,22 @@ exp :: { ECP } | infixexp '-<' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu Annlarrowtail $2) cs) $1 $3 + amsA' (sLL $1 $> $ HsCmdArrApp (mu Annlarrowtail $2) $1 $3 HsFirstOrderApp True) } | infixexp '>-' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu Annrarrowtail $2) cs) $3 $1 + amsA' (sLL $1 $> $ HsCmdArrApp (mu Annrarrowtail $2) $3 $1 HsFirstOrderApp False) } | infixexp '-<<' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu AnnLarrowtail $2) cs) $1 $3 + amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnLarrowtail $2) $1 $3 HsHigherOrderApp True) } | infixexp '>>-' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - acsA (\cs -> sLL $1 $> $ HsCmdArrApp (EpAnn (glEE $1 $>) (mu AnnRarrowtail $2) cs) $3 $1 + amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnRarrowtail $2) $3 $1 HsHigherOrderApp False) } -- See Note [%shift: exp -> infixexp] | infixexp %shift { $1 } @@ -2872,7 +2870,7 @@ aexp :: { ECP } mkHsLamPV (comb2 $1 $>) LamSingle (sLLl $1 $> [sLLa $1 $> - $ Match { m_ext = EpAnn (glEE $1 $>) [] emptyComments + $ Match { m_ext = [] , m_ctxt = LamAlt LamSingle , m_pats = $2 , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }]) @@ -2942,7 +2940,7 @@ aexp1 :: { ECP } | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> fmap ecpFromExp $ amsA' ( - let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in + let fl = sLLa $2 $> (DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) $3) in sLL $1 $> $ mkRdrGetField $1 fl) } @@ -3031,8 +3029,8 @@ projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } projection -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer : projection TIGHT_INFIX_PROJ field - {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) } - | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (EpAnn (glEE $1 $>) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) } + { sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) $3) `NE.cons` unLoc $1) } + | PREFIX_PROJ field { sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (AnnFieldLabel (Just $ glAA $1)) $2) :| [])} splice_exp :: { LHsExpr GhcPs } : splice_untyped { fmap (HsUntypedSplice noExtField) (reLoc $1) } @@ -3233,7 +3231,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau (h:t) -> do h' <- addTrailingCommaA h (gl $2) return (sLL $1 $> ($3 : (h':t))) } - | transformqual {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) } + | transformqual { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])] } | qual {% runPV $1 >>= \ $1 -> return $ sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } @@ -3247,22 +3245,19 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* : 'then' exp {% runPV (unECP $2) >>= \ $2 -> - acs (\cs-> - sLL $1 $> (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen $1] cs) ss $2))) } + return ( + sLL $1 $> (\r ss -> (mkTransformStmt [mj AnnThen $1] ss $2))) } | 'then' exp 'by' exp {% runPV (unECP $2) >>= \ $2 -> runPV (unECP $4) >>= \ $4 -> - acs (\cs -> sLL $1 $> ( - \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) } + return (sLL $1 $> (\r ss -> (mkTransformByStmt [mj AnnThen $1,mj AnnBy $3] ss $2 $4))) } | 'then' 'group' 'using' exp {% runPV (unECP $4) >>= \ $4 -> - acs (\cs -> sLL $1 $> ( - \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) } + return (sLL $1 $> (\r ss -> (mkGroupUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] ss $4))) } | 'then' 'group' 'by' exp 'using' exp {% runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> - acs (\cs -> sLL $1 $> ( - \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) } + return (sLL $1 $> (\r ss -> (mkGroupByUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] ss $4 $6))) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this @@ -3325,7 +3320,7 @@ alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } : PATS alt_rhs { $2 >>= \ $2 -> acsA (\cs -> sLLAsl $1 $> - (Match { m_ext = EpAnn (listAsAnchor $1 $>) [] cs + (Match { m_ext = [] , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing , m_pats = $1 , m_grhss = unLoc $2 }))} @@ -3434,18 +3429,14 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - acsA (\cs -> (sLL $1 $> $ mkRecStmt - (EpAnn (glEE $1 $>) (hsDoAnn $1 $2 AnnRec) cs) - $2)) } + amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn $1 $2 AnnRec) $2) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : bindpat '<-' exp { unECP $3 >>= \ $3 -> - acsA (\cs -> sLL $1 $> - $ mkPsBindStmt (EpAnn (glEE $1 $>) [mu AnnLarrow $2] cs) $1 $3) } + amsA' (sLL $1 $> $ mkPsBindStmt [mu AnnLarrow $2] $1 $3) } | exp { unECP $1 >>= \ $1 -> return $ sL1a $1 $ mkBodyStmt $1 } - | 'let' binds { acsA (\cs -> (sLL $1 $> - $ mkLetStmt (EpAnn (glEE $1 $>) [mj AnnLet $1] cs) (unLoc $2))) } + | 'let' binds { amsA' (sLL $1 $> $ mkLetStmt [mj AnnLet $1] (unLoc $2)) } ----------------------------------------------------------------------------- -- Record Field Update/Construction @@ -3466,13 +3457,13 @@ fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) } fbind :: { forall b. DisambECP b => PV (Fbind b) } : qvar '=' texp { unECP $3 >>= \ $3 -> - fmap Left $ acsA (\cs -> sLL $1 $> $ HsFieldBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (sL1a $1 $ mkFieldOcc $1) $3 False) } + fmap Left $ amsA' (sLL $1 $> $ HsFieldBind [mj AnnEqual $2] (sL1a $1 $ mkFieldOcc $1) $3 False) } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... | qvar { placeHolderPunRhs >>= \rhs -> - fmap Left $ acsA (\cs -> sL1 $1 $ HsFieldBind (EpAnn (glR $1) [] cs) (sL1a $1 $ mkFieldOcc $1) rhs True) } + fmap Left $ amsA' (sL1 $1 $ HsFieldBind [] (sL1a $1 $ mkFieldOcc $1) rhs True) } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -3483,7 +3474,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) } let top = sL1a $1 $ DotFieldOcc noAnn $1 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (L lf ()) - fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t + fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) f) : t final = last fields l = comb2 $1 $3 isPun = False @@ -3499,7 +3490,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) } let top = sL1a $1 $ DotFieldOcc noAnn $1 ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (L lf ()) - fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t + fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) f) : t final = last fields l = comb2 $1 $3 isPun = True @@ -3510,10 +3501,8 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) } fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] } fieldToUpdate -- See Note [Whitespace-sensitive operator parsing] in Lexer.x - : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLocA $3) >>= \cs -> - return (sLL $1 $> ((sLLa $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) } - | field {% getCommentsFor (getLocA $1) >>= \cs -> - return (sL1 $1 [sL1a $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) } + : fieldToUpdate TIGHT_INFIX_PROJ field { sLL $1 $> ((sLLa $2 $> (DotFieldOcc (AnnFieldLabel $ Just $ glAA $2) $3)) : unLoc $1) } + | field { sL1 $1 [sL1a $1 (DotFieldOcc (AnnFieldLabel Nothing) $1)] } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -3534,7 +3523,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed dbind :: { LIPBind GhcPs } dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 -> - acsA (\cs -> sLL $1 $> (IPBind (EpAnn (glEE $1 $>) [mj AnnEqual $2] cs) (reLoc $1) $3)) } + amsA' (sLL $1 $> (IPBind [mj AnnEqual $2] (reLoc $1) $3)) } ipvar :: { Located HsIPName } : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -351,9 +351,8 @@ mkTyFamInst :: SrcSpan -> [AddEpAnn] -> P (LInstDecl GhcPs) mkTyFamInst loc eqn anns = do - cs <- getCommentsFor loc return (L (noAnnSrcSpan loc) (TyFamInstD noExtField - (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn))) + (TyFamInstDecl anns eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -365,13 +364,10 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl GhcPs) mkFamDecl loc info topLevel lhs ksig injAnn annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams - ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) ; return (L (noAnnSrcSpan loc) (FamDecl noExtField (FamilyDecl - { fdExt = anns' + { fdExt = annsIn Semi.<> ann , fdTopLevel = topLevel , fdInfo = info, fdLName = tc , fdTyVars = tyvars @@ -776,7 +772,7 @@ recordPatSynErr loc pat = addFatalError $ mkPlainErrorMsgEnvelope loc $ (PsErrRecordSyntaxInPatSynDecl pat) -mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] +mkConDeclH98 :: [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs @@ -802,8 +798,6 @@ mkGadtDecl :: SrcSpan -> LHsSigType GhcPs -> P (LConDecl GhcPs) mkGadtDecl loc names dcol ty = do - cs <- getCommentsFor loc - let l = noAnnSrcSpan loc (args, res_ty, annsa, csa) <- case body_ty of @@ -820,14 +814,14 @@ mkGadtDecl loc names dcol ty = do let (anns, cs, arg_types, res_type) = splitHsFunType body_ty return (PrefixConGADT noExtField arg_types, res_type, anns, cs) - let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa) - let bndrs_loc = case outer_bndrs of HsOuterImplicit{} -> getLoc ty HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments + let l = EpAnn (spanAsAnchor loc) noAnn csa + pure $ L l ConDeclGADT - { con_g_ext = (dcol, an) + { con_g_ext = (dcol, annsa) , con_names = names , con_bndrs = L bndrs_loc outer_bndrs , con_mb_cxt = mcxt @@ -1238,10 +1232,10 @@ checkAPat loc e0 = do (L _ (PatBuilderVar (L nloc n))) (L l plus) (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - (EpAnn anc _ cs) + _ | nPlusKPatterns && (plus == plus_RDR) -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit) - (EpAnn anc (entry l) cs)) + (entry l)) -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do @@ -1323,9 +1317,8 @@ checkFunBind :: SrcStrictness checkFunBind strictness locF ann fun is_infix pats (L _ grhss) = do ps <- runPV_details extraDetails (mapM checkLPat pats) let match_span = noAnnSrcSpan $ locF - cs <- getCommentsFor locF return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) - [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs + [L match_span (Match { m_ext = ann , m_ctxt = FunRhs { mc_fun = fun , mc_fixity = is_infix @@ -1353,10 +1346,10 @@ checkPatBind :: SrcSpan -> LPat GhcPs -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs) -checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v)))) +checkPatBind loc annsIn (L _ (BangPat ans (L _ (VarPat _ v)))) (L _match_span grhss) = return (makeFunBind v (L (noAnnSrcSpan loc) - [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)])) + [L (noAnnSrcSpan loc) (m (ans++annsIn) v)])) where m a v = Match { m_ext = a , m_ctxt = FunRhs { mc_fun = v @@ -1407,7 +1400,7 @@ isFunLhs e = go e [] [] [] (o,c) = mkParensEpAnn (realSrcSpan $ locA l) in go e es (o:ops) (c:cps) - go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps + go (L loc (PatBuilderOpApp l (L loc' op) r anns)) es ops cps | not (isRdrDataCon op) -- We have found the function! = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps))) | otherwise -- Infix data con; keep going @@ -1417,7 +1410,7 @@ isFunLhs e = go e [] [] [] -> return (Just (op', Infix, j : op_app : es', anns')) where op_app = L loc (PatBuilderOpApp k - (L loc' op) r (EpAnn loca (reverse ops++cps) cs)) + (L loc' op) r (reverse ops++cps)) _ -> return Nothing } go _ _ _ _ = return Nothing @@ -1678,7 +1671,7 @@ instance DisambECP (HsCmd GhcPs) where mkHsLamPV l lam_variant (L lm m) anns = do cs <- getCommentsFor l let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) - return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) lam_variant mg) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg) mkHsLetPV l tkLet bs tkIn e = do cs <- getCommentsFor l @@ -1696,23 +1689,22 @@ instance DisambECP (HsCmd GhcPs) where mkHsCasePV l c (L lm m) anns = do cs <- getCommentsFor l let mg = mkMatchGroup FromSource (L lm m) - return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg) type FunArg (HsCmd GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l c e = do - cs <- getCommentsFor (locA l) checkCmdBlockArguments c checkExpBlockArguments e - return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e) + return $ L l (HsCmdApp noExtField c e) mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs)) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) mkHsDoPV l Nothing stmts anns = do cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo anns stmts) mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do cs <- getCommentsFor l @@ -1763,7 +1755,7 @@ instance DisambECP (HsExpr GhcPs) where ecpFromExp' = return mkHsProjUpdatePV l fields arg isPun anns = do cs <- getCommentsFor l - return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs) + return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns mkHsLetPV l tkLet bs tkIn c = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c) @@ -1862,8 +1854,7 @@ instance DisambECP (PatBuilder GhcPs) where superInfixOp m = m mkHsOpAppPV l p1 op p2 = do cs <- getCommentsFor l - let anns = EpAnn (spanAsAnchor l) [] cs - return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 [] mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant) @@ -1887,12 +1878,11 @@ instance DisambECP (PatBuilder GhcPs) where mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig anns = do p <- checkLPat b - cs <- getCommentsFor (locA l) - return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig))) + return $ L l (PatBuilderPat (SigPat anns p (mkHsPatSigType noAnn sig))) mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs cs <- getCommentsFor l - return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps))) + return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps))) mkHsSplicePV (L l sp) = do cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp)) @@ -1902,20 +1892,19 @@ instance DisambECP (PatBuilder GhcPs) where then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid else do cs <- getCommentsFor l - r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs) - checkRecordSyntax (L (noAnnSrcSpan l) r) + r <- mkPatRec a (mk_rec_fields fs ddLoc) anns + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) mkHsNegAppPV l (L lp p) anns = do lit <- case p of PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) _ -> patFail l $ PsErrInPat p PEIP_NegApp cs <- getCommentsFor l - let an = EpAnn (spanAsAnchor l) anns cs - return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns)) mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) mkHsViewPatPV l a b anns = do p <- checkLPat b cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p)) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat anns a p)) mkHsAsPatPV l v at e = do p <- checkLPat e cs <- getCommentsFor l @@ -1923,13 +1912,13 @@ instance DisambECP (PatBuilder GhcPs) where mkHsLazyPatPV l e a = do p <- checkLPat e cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p)) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p)) mkHsBangPatPV l e an = do p <- checkLPat e cs <- getCommentsFor l - let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p + let pb = BangPat an p hintBangPat l pb - return $ L (noAnnSrcSpan l) (PatBuilderPat pb) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb) mkSumOrTuplePV = mkSumOrTuplePat mkHsEmbTyPV l toktype ty = return $ L (noAnnSrcSpan l) $ @@ -1965,7 +1954,7 @@ checkUnboxedLitPat (L loc lit) = mkPatRec :: LocatedA (PatBuilder GhcPs) -> HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> - EpAnn [AddEpAnn] -> + [AddEpAnn] -> PV (PatBuilder GhcPs) mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns | isRdrDataCon (unLoc c) @@ -2694,7 +2683,7 @@ checkNewOrData span name is_type_data = curry $ \ case mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) + -> P ([AddEpAnn] -> HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of CCallConv -> returnSpec =<< mkCImport @@ -2804,7 +2793,7 @@ parseCImport cconv safety nm str sourceText = -- mkExport :: Located CCallConv -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) + -> P ([AddEpAnn] -> HsDecl GhcPs) mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) = return $ \ann -> ForD noExtField $ ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty @@ -2837,17 +2826,17 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) mkModuleImpExp warning anns (L l specname) subs = do - cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments - let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs + -- cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments + -- let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> return $ IEVar warning (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs (warning, ann) . L l <$> nameT - ImpExpAll -> IEThingAll (warning, ann) . L l <$> nameT + | otherwise -> IEThingAbs (warning, anns) . L l <$> nameT + ImpExpAll -> IEThingAll (warning, anns) . L l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith (warning, ann) (L l newName) + (\newName -> IEThingWith (warning, anns) (L l newName) NoIEWildcard (wrapped xs)) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2859,7 +2848,7 @@ mkModuleImpExp warning anns (L l specname) subs = do ies :: [LocatedA (IEWrappedName GhcPs)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith (warning, ann) (L l newName) pos ies) + -> IEThingWith (warning, anns) (L l newName) pos ies) <$> nameT else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrIllegalPatSynExport @@ -3138,8 +3127,7 @@ mkSumOrTuplePat -- Tuple mkSumOrTuplePat l boxity (Tuple ps) anns = do ps' <- traverse toTupPat ps - cs <- getCommentsFor (locA l) - return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity)) + return $ L l (PatBuilderPat (TuplePat anns ps' boxity)) where toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) -- Ignore the element location so that the error message refers to the @@ -3152,8 +3140,7 @@ mkSumOrTuplePat l boxity (Tuple ps) anns = do -- Sum mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do p' <- checkLPat p - cs <- getCommentsFor (locA l) - let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs + let an = EpAnnSumPat anns barsb barsa return $ L l (PatBuilderPat (SumPat an p' alt arity)) mkSumOrTuplePat l Boxed a at Sum{} _ = addFatalError $ @@ -3214,7 +3201,7 @@ mkRdrProjection flds anns = } mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] - -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn] + -> LHsExpr GhcPs -> Bool -> [AddEpAnn] -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns = ===================================== compiler/GHC/Parser/Types.hs ===================================== @@ -57,7 +57,7 @@ data PatBuilder p | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) - (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) + (LocatedA (PatBuilder p)) [AddEpAnn] | PatBuilderVar (LocatedN RdrName) | PatBuilderOverLit (HsOverLit GhcPs) ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -80,11 +80,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { T22919.hs:2:1-9 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/Test20239.stderr ===================================== @@ -124,11 +124,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { Test20239.hs:5:36-55 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { Test20239.hs:5:36-49 }) @@ -176,11 +172,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { Test20239.hs:7:36-86 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { Test20239.hs:7:36-48 }) ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -92,11 +92,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { ZeroWidthSemi.hs:6:1-5 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr ===================================== @@ -796,11 +796,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:22:20-28 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:22:20-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:22:20-23 }))] (DataFamily) (NotTopLevel) (L @@ -988,11 +984,7 @@ (EpUniTok (EpaSpan { T17544.hs:25:10-11 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:25:5-18 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -1133,11 +1125,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:28:20-28 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:28:20-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:28:20-23 }))] (DataFamily) (NotTopLevel) (L @@ -1325,11 +1313,7 @@ (EpUniTok (EpaSpan { T17544.hs:31:10-11 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:31:5-18 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -1470,11 +1454,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:34:20-28 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:34:20-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:34:20-23 }))] (DataFamily) (NotTopLevel) (L @@ -1662,11 +1642,7 @@ (EpUniTok (EpaSpan { T17544.hs:37:10-11 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:37:5-18 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -1807,11 +1783,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:40:20-28 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:40:20-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:40:20-23 }))] (DataFamily) (NotTopLevel) (L @@ -1999,11 +1971,7 @@ (EpUniTok (EpaSpan { T17544.hs:43:10-11 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:43:5-18 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -2144,11 +2112,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:46:20-28 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:46:20-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:46:20-23 }))] (DataFamily) (NotTopLevel) (L @@ -2336,11 +2300,7 @@ (EpUniTok (EpaSpan { T17544.hs:49:10-11 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:49:5-18 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -2481,11 +2441,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaSpan { T17544.hs:52:21-30 }) - [(AddEpAnn AnnData (EpaSpan { T17544.hs:52:21-24 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { T17544.hs:52:21-24 }))] (DataFamily) (NotTopLevel) (L @@ -2673,11 +2629,7 @@ (EpUniTok (EpaSpan { T17544.hs:55:11-12 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544.hs:55:5-20 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn ===================================== testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr ===================================== @@ -89,11 +89,7 @@ (EpUniTok (EpaSpan { T17544_kw.hs:16:15-16 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544_kw.hs:16:9-20 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -194,11 +190,7 @@ (EpUniTok (EpaSpan { T17544_kw.hs:19:15-16 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T17544_kw.hs:19:9-26 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -101,11 +101,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { mod185.hs:5:1-24 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -109,11 +109,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { DumpParsedAst.hs:7:14-17 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpParsedAst.hs:7:14-17 }) @@ -138,11 +134,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { DumpParsedAst.hs:7:21-30 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpParsedAst.hs:7:21-24 }) @@ -290,14 +282,10 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaSpan { DumpParsedAst.hs:(10,1)-(12,24) }) - [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:10:1-4 })) - ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:10:6-11 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:32-33 })) - ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:10:41-45 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:10:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:10:6-11 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:32-33 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:10:41-45 }))] (ClosedTypeFamily (Just [(L @@ -728,11 +716,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { DumpParsedAst.hs:15:21-29 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpParsedAst.hs:15:21-23 }) @@ -984,14 +968,10 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaSpan { DumpParsedAst.hs:(18,1)-(19,30) }) - [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:18:1-4 })) - ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:18:6-11 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:42-43 })) - ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:18:50-54 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:18:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:18:6-11 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:18:42-43 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:18:50-54 }))] (ClosedTypeFamily (Just [(L @@ -1350,13 +1330,9 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaSpan { DumpParsedAst.hs:21:1-33 }) - [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:21:1-4 })) - ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:21:6-11 })) - ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:21:17-18 }))] - (EpaComments - [])) + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:21:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:21:6-11 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:21:17-18 }))] (DataFamily) (TopLevel) (L @@ -1699,11 +1675,7 @@ (EpUniTok (EpaSpan { DumpParsedAst.hs:23:7-8 }) (NormalSyntax)) - (EpAnn - (EpaSpan { DumpParsedAst.hs:23:3-45 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn @@ -2005,11 +1977,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpParsedAst.hs:25:1-23 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -101,11 +101,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:9:1-7 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -216,11 +212,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:(14,1)-(16,3) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -363,11 +355,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpParsedAstComments.hs:19:1-23 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -49,11 +49,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -244,11 +240,7 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (ClosedTypeFamily (Just [(L @@ -666,11 +658,7 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (DataFamily) (TopLevel) (L @@ -1425,11 +1413,7 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (ClosedTypeFamily (Just [(L @@ -1960,11 +1944,7 @@ (EpaComments [])) (FamilyDecl - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (OpenTypeFamily) (NotTopLevel) (L @@ -2119,11 +2099,7 @@ (EpaComments [])) (TyFamInstDecl - (EpAnn - (EpaSpan { DumpRenamedAst.hs:32:3-27 }) - [(AddEpAnn AnnType (EpaSpan { DumpRenamedAst.hs:32:3-6 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { DumpRenamedAst.hs:32:3-6 }))] (FamEqn [] (L @@ -2404,11 +2380,7 @@ (IEThingAbs ((,) (Nothing) - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - []))) + []) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:7:19-22 }) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -264,11 +264,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:(10,1)-(12,3) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -559,11 +555,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:(15,1)-(19,3) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -809,11 +801,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:22:1-30 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1014,11 +1002,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:24:1-13 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1111,11 +1095,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:25:1-13 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1209,11 +1189,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:26:1-13 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1677,11 +1653,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:32:1-7 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1794,11 +1766,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:34:8-35 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1906,11 +1874,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:34:19-21 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -2006,11 +1970,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:34:24-26 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -2123,11 +2083,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:(36,1)-(44,4) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -2233,11 +2189,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:39:6-13 }) - [] - (EpaComments - [])) + [] (CaseAlt) [(L (EpAnn @@ -2247,11 +2199,7 @@ (EpaComments [])) (NPat - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpSemis.hs:39:6 }) @@ -2308,11 +2256,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:40:6-13 }) - [] - (EpaComments - [])) + [] (CaseAlt) [(L (EpAnn @@ -2322,11 +2266,7 @@ (EpaComments [])) (NPat - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpSemis.hs:40:6 }) @@ -2385,11 +2325,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:41:6-13 }) - [] - (EpaComments - [])) + [] (CaseAlt) [(L (EpAnn @@ -2399,11 +2335,7 @@ (EpaComments [])) (NPat - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpSemis.hs:41:6 }) @@ -2464,11 +2396,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { DumpSemis.hs:42:6-13 }) - [] - (EpaComments - [])) + [] (CaseAlt) [(L (EpAnn @@ -2478,11 +2406,7 @@ (EpaComments [])) (NPat - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { DumpSemis.hs:42:6 }) ===================================== testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr ===================================== @@ -1951,11 +1951,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -80,13 +80,9 @@ (FamDecl (NoExtField) (FamilyDecl - (EpAnn - (EpaSpan { KindSigs.hs:(11,1)-(12,21) }) - [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:11:1-4 })) - ,(AddEpAnn AnnFamily (EpaSpan { KindSigs.hs:11:6-11 })) - ,(AddEpAnn AnnWhere (EpaSpan { KindSigs.hs:11:19-23 }))] - (EpaComments - [])) + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:11:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { KindSigs.hs:11:6-11 })) + ,(AddEpAnn AnnWhere (EpaSpan { KindSigs.hs:11:19-23 }))] (ClosedTypeFamily (Just [(L @@ -938,11 +934,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { KindSigs.hs:23:1-12 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -1601,11 +1593,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { KindSigs.hs:35:1-11 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T14189.stderr ===================================== @@ -156,11 +156,7 @@ (EpaComments [])) (ConDeclField - (EpAnn - (EpaDelta (SameLine 0) []) - [] - (EpaComments - [])) + [] [(L (EpAnn (EpaSpan { T14189.hs:6:33 }) @@ -259,12 +255,8 @@ (IEThingWith ((,) (Nothing) - (EpAnn - (EpaSpan { T14189.hs:3:3-8 }) - [(AddEpAnn AnnOpenP (EpaSpan { T14189.hs:3:10 })) - ,(AddEpAnn AnnCloseP (EpaSpan { T14189.hs:3:15 }))] - (EpaComments - []))) + [(AddEpAnn AnnOpenP (EpaSpan { T14189.hs:3:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T14189.hs:3:15 }))]) (L (EpAnn (EpaSpan { T14189.hs:3:3-8 }) ===================================== testsuite/tests/parser/should_compile/T15323.stderr ===================================== @@ -96,11 +96,7 @@ (EpUniTok (EpaSpan { T15323.hs:6:17-18 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T15323.hs:6:5-54 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20452.stderr ===================================== @@ -113,11 +113,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { T20452.hs:5:26-31 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { T20452.hs:5:26-31 }) @@ -217,11 +213,7 @@ (EpaComments [])) (ConDeclH98 - (EpAnn - (EpaSpan { T20452.hs:6:26-31 }) - [] - (EpaComments - [])) + [] (L (EpAnn (EpaSpan { T20452.hs:6:26-31 }) ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -114,11 +114,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { T20718.hs:8:1-5 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -101,11 +101,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { T20846.hs:4:1-18 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== testsuite/tests/printer/T18791.stderr ===================================== @@ -77,11 +77,7 @@ (EpUniTok (EpaSpan { T18791.hs:5:7-8 }) (NormalSyntax)) - (EpAnn - (EpaSpan { T18791.hs:5:3-17 }) - [] - (EpaComments - []))) + []) (:| (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -80,11 +80,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.hs:(5,1)-(7,7) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -204,11 +200,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.hs:(9,1)-(11,26) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -318,11 +310,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.hs:11:9-26 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -499,11 +487,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.ppr.hs:(3,1)-(5,7) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -611,11 +595,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.ppr.hs:(6,1)-(9,24) }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn @@ -719,11 +699,7 @@ (EpaComments [])) (Match - (EpAnn - (EpaSpan { Test20297.ppr.hs:9:7-24 }) - [] - (EpaComments - [])) + [] (FunRhs (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -608,23 +608,8 @@ flushComments trailing_anns = do -- |In order to interleave annotations into the stream, we turn them into -- comments. They are removed from the annotation to avoid duplication. annotationsToComments :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m (EpAnn a) -annotationsToComments (EpAnn anc a cs) l kws = do - let (newComments, newAnns) = go ([],[]) (view l a) - addComments newComments - return (EpAnn anc (set l (reverse newAnns) a) cs) - where - keywords = Set.fromList kws - - go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) - go acc [] = acc - go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k (epaToNoCommentsLocation ss)):cs', ans) ls - | otherwise = go (cs', (AddEpAnn k ss):ans) ls - -annotationsToComments' :: (Monad m, Monoid w) => a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m a -annotationsToComments' a l kws = do +annotationsToComments a l kws = do let (newComments, newAnns) = go ([],[]) (view l a) addComments newComments return (set l (reverse newAnns) a) @@ -723,10 +708,10 @@ printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLoc printStringAtAA el str = printStringAtAAC CaptureComments el str printStringAtAAL :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> String -> EP w m (EpAnn a) -printStringAtAAL (EpAnn anc an cs) l str = do + => a -> Lens a EpaLocation -> String -> EP w m a +printStringAtAAL an l str = do r <- printStringAtAAC CaptureComments (view l an) str - return (EpAnn anc (set l r an) cs) + return (set l r an) printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation @@ -1328,14 +1313,8 @@ markLensKw' a l kw = do return (set l loc a) markAnnKwAllL :: (Monad m, Monoid w) - => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a) -markAnnKwAllL (EpAnn anc a cs) l kw = do - anns <- mapM (markKwA kw) (view l a) - return (EpAnn anc (set l anns a) cs) - -markAnnKwAllL' :: (Monad m, Monoid w) => a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m a -markAnnKwAllL' a l kw = do +markAnnKwAllL a l kw = do anns <- mapM (markKwA kw) (view l a) return (set l anns a) @@ -1456,6 +1435,13 @@ markAnnList ann action = do r <- action return (a,r) +markAnnList' :: (Monad m, Monoid w) + => AnnList -> EP w m a -> EP w m (AnnList, a) +markAnnList' ann action = do + markAnnListA' ann $ \a -> do + r <- action + return (a,r) + markAnnListA :: (Monad m, Monoid w) => EpAnn AnnList -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a)) @@ -2003,29 +1989,26 @@ instance ExactPrint (DerivDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (ForeignDecl GhcPs) where - getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an - getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an - - setAnnotationAnchor (ForeignImport an a b c) anc ts cs = ForeignImport (setAnchorEpa an anc ts cs) a b c - setAnnotationAnchor (ForeignExport an a b c) anc ts cs = ForeignExport (setAnchorEpa an anc ts cs) a b c + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (ForeignImport an n ty fimport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnImport + an0 <- markEpAnnL' an lidl AnnForeign + an1 <- markEpAnnL' an0 lidl AnnImport fimport' <- markAnnotated fimport n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon + an2 <- markEpAnnL' an1 lidl AnnDcolon ty' <- markAnnotated ty return (ForeignImport an2 n' ty' fimport') exact (ForeignExport an n ty fexport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnExport + an0 <- markEpAnnL' an lidl AnnForeign + an1 <- markEpAnnL' an0 lidl AnnExport fexport' <- markAnnotated fexport n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon + an2 <- markEpAnnL' an1 lidl AnnDcolon ty' <- markAnnotated ty return (ForeignExport an2 n' ty' fexport') @@ -2378,12 +2361,12 @@ instance ExactPrint (ClsInstDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (TyFamInstDecl GhcPs) where - getAnnotationEntry (TyFamInstDecl an _) = fromAnn an - setAnnotationAnchor (TyFamInstDecl an a) anc ts cs = TyFamInstDecl (setAnchorEpa an anc ts cs) a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnInstance + an0 <- markEpAnnL' an lidl AnnType + an1 <- markEpAnnL' an0 lidl AnnInstance eqn' <- markAnnotated eqn return (d { tfid_xtn = an1, tfid_eqn = eqn' }) @@ -2453,14 +2436,14 @@ instance ExactPrint (HsBind GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (PatSynBind GhcPs GhcPs) where - getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an - setAnnotationAnchor p anc ts cs = p { psb_ext = setAnchorEpa (psb_ext p) anc ts cs} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (PSB{ psb_ext = an , psb_id = psyn, psb_args = details , psb_def = pat , psb_dir = dir }) = do - an0 <- markEpAnnL an lidl AnnPattern + an0 <- markEpAnnL' an lidl AnnPattern (an1, psyn', details') <- case details of InfixCon v1 v2 -> do @@ -2475,25 +2458,25 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where return (an0, psyn', PrefixCon tvs' vs') RecCon vs -> do psyn' <- markAnnotated psyn - an1 <- markEpAnnL an0 lidl AnnOpenC -- '{' + an1 <- markEpAnnL' an0 lidl AnnOpenC -- '{' vs' <- markAnnotated vs - an2 <- markEpAnnL an1 lidl AnnCloseC -- '}' + an2 <- markEpAnnL' an1 lidl AnnCloseC -- '}' return (an2, psyn', RecCon vs') (an2, pat', dir') <- case dir of Unidirectional -> do - an2 <- markEpAnnL an1 lidl AnnLarrow + an2 <- markEpAnnL' an1 lidl AnnLarrow pat' <- markAnnotated pat return (an2, pat', dir) ImplicitBidirectional -> do - an2 <- markEpAnnL an1 lidl AnnEqual + an2 <- markEpAnnL' an1 lidl AnnEqual pat' <- markAnnotated pat return (an2, pat', dir) ExplicitBidirectional mg -> do - an2 <- markEpAnnL an1 lidl AnnLarrow + an2 <- markEpAnnL' an1 lidl AnnLarrow pat' <- markAnnotated pat - an3 <- markEpAnnL an2 lidl AnnWhere + an3 <- markEpAnnL' an2 lidl AnnWhere mg' <- markAnnotated mg return (an3, pat', ExplicitBidirectional mg') @@ -2514,8 +2497,8 @@ instance ExactPrint (RecordPatSynField GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - setAnnotationAnchor (Match an a b c) anc ts cs = Match (setAnchorEpa an anc ts cs) a b c + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (Match an mctxt pats grhss) = exactMatch (Match an mctxt pats grhss) @@ -2523,8 +2506,8 @@ instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where -- ------------------------------------- instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - setAnnotationAnchor (Match an a b c) anc ts cs = Match (setAnchorEpa an anc ts cs) a b c + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (Match an mctxt pats grhss) = exactMatch (Match an mctxt pats grhss) @@ -2543,7 +2526,7 @@ exactMatch (Match an mctxt pats grhss) = do debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun an0' <- case strictness of - SrcStrict -> markEpAnnL an lidl AnnBang + SrcStrict -> markEpAnnL' an lidl AnnBang _ -> pure an case fixity of Prefix -> do @@ -2560,18 +2543,18 @@ exactMatch (Match an mctxt pats grhss) = do p2' <- markAnnotated p2 return (an0', FunRhs fun' fixity strictness, [p1',p2']) | otherwise -> do - an0 <- markEpAnnL an0' lidl AnnOpenP + an0 <- markEpAnnL' an0' lidl AnnOpenP p1' <- markAnnotated p1 fun' <- markAnnotated fun p2' <- markAnnotated p2 - an1 <- markEpAnnL an0 lidl AnnCloseP + an1 <- markEpAnnL' an0 lidl AnnCloseP rest' <- mapM markAnnotated rest return (an1, FunRhs fun' fixity strictness, p1':p2':rest') _ -> panic "FunRhs" -- ToDo: why is LamSingle treated differently? LamAlt LamSingle -> do - an0' <- markEpAnnL an lidl AnnLam + an0' <- markEpAnnL' an lidl AnnLam pats' <- markAnnotated pats return (an0', LamAlt LamSingle, pats') LamAlt v -> do @@ -2676,12 +2659,12 @@ instance ExactPrint (HsIPBinds GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (IPBind GhcPs) where - getAnnotationEntry (IPBind an _ _) = fromAnn an - setAnnotationAnchor (IPBind an a b) anc ts cs = IPBind (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (IPBind an lr rhs) = do lr' <- markAnnotated lr - an0 <- markEpAnnL an lidl AnnEqual + an0 <- markEpAnnL' an lidl AnnEqual rhs' <- markAnnotated rhs return (IPBind an0 lr' rhs') @@ -2835,14 +2818,14 @@ instance ExactPrint (StandaloneKindSig GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (DefaultDecl GhcPs) where - getAnnotationEntry (DefaultDecl an _) = fromAnn an - setAnnotationAnchor (DefaultDecl an a) anc ts cs = DefaultDecl (setAnchorEpa an anc ts cs) a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (DefaultDecl an tys) = do - an0 <- markEpAnnL an lidl AnnDefault - an1 <- markEpAnnL an0 lidl AnnOpenP + an0 <- markEpAnnL' an lidl AnnDefault + an1 <- markEpAnnL' an0 lidl AnnOpenP tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseP + an2 <- markEpAnnL' an1 lidl AnnCloseP return (DefaultDecl an2 tys') -- --------------------------------------------------------------------- @@ -3034,9 +3017,9 @@ instance ExactPrint (HsExpr GhcPs) where exact (ExplicitSum an alt arity expr) = do an0 <- markLensKw' an laesOpen AnnOpenPH - an1 <- markAnnKwAllL' an0 laesBarsBefore AnnVbar + an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar expr' <- markAnnotated expr - an2 <- markAnnKwAllL' an1 laesBarsAfter AnnVbar + an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar an3 <- markLensKw' an2 laesClose AnnClosePH return (ExplicitSum an3 alt arity expr') @@ -3330,14 +3313,15 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where instance (ExactPrint body) => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind" f' <- markAnnotated f (an0, arg') <- if isPun then return (an, arg) else do - an0 <- markEpAnnL an lidl AnnEqual + an0 <- markEpAnnL' an lidl AnnEqual arg' <- markAnnotated arg return (an0, arg') return (HsFieldBind an0 f' arg' isPun) @@ -3346,15 +3330,15 @@ instance (ExactPrint body) instance (ExactPrint body) => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind FieldLabelStrings" f' <- markAnnotated f (an0, arg') <- if isPun then return (an, arg) else do - an0 <- markEpAnnL an lidl AnnEqual + an0 <- markEpAnnL' an lidl AnnEqual arg' <- markAnnotated arg return (an0, arg') return (HsFieldBind an0 f' arg' isPun) @@ -3363,13 +3347,14 @@ instance (ExactPrint body) instance (ExactPrint (LocatedA body)) => ExactPrint (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc ts cs = (HsFieldBind (setAnchorEpa an anc ts cs) f arg isPun) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsFieldBind an f arg isPun) = do debugM $ "HsRecUpdField" f' <- markAnnotated f an0 <- if isPun then return an - else markEpAnnL an lidl AnnEqual + else markEpAnnL' an lidl AnnEqual arg' <- if isPun then return arg else markAnnotated arg @@ -3399,12 +3384,11 @@ instance ExactPrint (FieldLabelStrings GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (DotFieldOcc GhcPs) where - getAnnotationEntry (DotFieldOcc an _) = fromAnn an - - setAnnotationAnchor (DotFieldOcc an a) anc ts cs = DotFieldOcc (setAnchorEpa an anc ts cs) a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do - an0 <- markLensKwM an lafDot AnnDot + an0 <- markLensKwM' an lafDot AnnDot -- The field name has a SrcSpanAnnN, print it as a -- LocatedN RdrName L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) @@ -3435,40 +3419,21 @@ instance ExactPrint (HsCmdTop GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (HsCmd GhcPs) where - getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdArrForm _ _ _ _ _ ) = NoEntryVal - getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an - getAnnotationEntry (HsCmdPar _ _) = NoEntryVal - getAnnotationEntry (HsCmdCase an _ _) = fromAnn an - getAnnotationEntry (HsCmdLam an _ _) = fromAnn an - getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet _ _ _) = NoEntryVal - getAnnotationEntry (HsCmdDo an _) = fromAnn an - - setAnnotationAnchor (HsCmdArrApp an a b c d) anc ts cs = (HsCmdArrApp (setAnchorEpa an anc ts cs) a b c d) - setAnnotationAnchor a@(HsCmdArrForm{}) _ _ _s = a - setAnnotationAnchor (HsCmdApp an a b ) anc ts cs = (HsCmdApp (setAnchorEpa an anc ts cs) a b ) - setAnnotationAnchor (HsCmdLam an a b) anc ts cs = (HsCmdLam (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(HsCmdPar _ _) _ _ _s = a - setAnnotationAnchor (HsCmdCase an a b) anc ts cs = (HsCmdCase (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (HsCmdIf an a b c d) anc ts cs = (HsCmdIf (setAnchorEpa an anc ts cs) a b c d) - setAnnotationAnchor a@(HsCmdLet _ _ _) _ _ _s = a - setAnnotationAnchor (HsCmdDo an a) anc ts cs = (HsCmdDo (setAnchorEpa an anc ts cs) a) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (HsCmdArrApp an arr arg o isRightToLeft) = do if isRightToLeft then do arr' <- markAnnotated arr - an0 <- markKw (anns an) + an0 <- markKw an arg' <- markAnnotated arg - let an1 = an{anns = an0} - return (HsCmdArrApp an1 arr' arg' o isRightToLeft) + return (HsCmdArrApp an0 arr' arg' o isRightToLeft) else do arg' <- markAnnotated arg - an0 <- markKw (anns an) + an0 <- markKw an arr' <- markAnnotated arr - let an1 = an {anns = an0} - return (HsCmdArrApp an1 arr' arg' o isRightToLeft) + return (HsCmdArrApp an0 arr' arg' o isRightToLeft) exact (HsCmdArrForm an e fixity mf cs) = do an0 <- markLensMAA' an lal_open @@ -3492,11 +3457,11 @@ instance ExactPrint (HsCmd GhcPs) where return (HsCmdApp an e1' e2') exact (HsCmdLam an lam_variant matches) = do - an0 <- markEpAnnL an lidl AnnLam + an0 <- markEpAnnL' an lidl AnnLam an1 <- case lam_variant of LamSingle -> return an0 - LamCase -> markEpAnnL an0 lidl AnnCase - LamCases -> markEpAnnL an0 lidl AnnCases + LamCase -> markEpAnnL' an0 lidl AnnCase + LamCases -> markEpAnnL' an0 lidl AnnCases matches' <- markAnnotated matches return (HsCmdLam an1 lam_variant matches') @@ -3507,23 +3472,23 @@ instance ExactPrint (HsCmd GhcPs) where return (HsCmdPar (lpar', rpar') e') exact (HsCmdCase an e alts) = do - an0 <- markLensKw an lhsCaseAnnCase AnnCase + an0 <- markLensKw' an lhsCaseAnnCase AnnCase e' <- markAnnotated e - an1 <- markLensKw an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi + an1 <- markLensKw' an0 lhsCaseAnnOf AnnOf + an2 <- markEpAnnL' an1 lhsCaseAnnsRest AnnOpenC + an3 <- markEpAnnAllL' an2 lhsCaseAnnsRest AnnSemi alts' <- markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC + an4 <- markEpAnnL' an3 lhsCaseAnnsRest AnnCloseC return (HsCmdCase an4 e' alts') exact (HsCmdIf an a e1 e2 e3) = do - an0 <- markLensKw an laiIf AnnIf + an0 <- markLensKw' an laiIf AnnIf e1' <- markAnnotated e1 - an1 <- markLensKwM an0 laiThenSemi AnnSemi - an2 <- markLensKw an1 laiThen AnnThen + an1 <- markLensKwM' an0 laiThenSemi AnnSemi + an2 <- markLensKw' an1 laiThen AnnThen e2' <- markAnnotated e2 - an3 <- markLensKwM an2 laiElseSemi AnnSemi - an4 <- markLensKw an3 laiElse AnnElse + an3 <- markLensKwM' an2 laiElseSemi AnnSemi + an4 <- markLensKw' an3 laiElse AnnElse e3' <- markAnnotated e3 return (HsCmdIf an4 a e1' e2' e3') @@ -3537,7 +3502,7 @@ instance ExactPrint (HsCmd GhcPs) where exact (HsCmdDo an es) = do debugM $ "HsCmdDo" - an0 <- markEpAnnL an lal_rest AnnDo + an0 <- markEpAnnL' an lal_rest AnnDo es' <- markAnnotated es return (HsCmdDo an0 es') @@ -3549,27 +3514,8 @@ instance ( Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where - getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (BindStmt an _ _) = fromAnn an - getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal - getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (LetStmt an _) = fromAnn an - getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an - getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an - - ----------------------------------------------------------------- - - setAnnotationAnchor a@(LastStmt _ _ _ _) _ _ _s = a - setAnnotationAnchor (BindStmt an a b) anc ts cs = (BindStmt (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _ _s = a - setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _ _s = a - setAnnotationAnchor (LetStmt an a) anc ts cs = (LetStmt (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(ParStmt _ _ _ _) _ _ _s = a - setAnnotationAnchor (TransStmt an a b c d e f g h) anc ts cs = (TransStmt (setAnchorEpa an anc ts cs) a b c d e f g h) - setAnnotationAnchor (RecStmt an a b c d e f) anc ts cs = (RecStmt (setAnchorEpa an anc ts cs) a b c d e f) - - ----------------------------------------------------------------- + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a exact (LastStmt a body b c) = do debugM $ "LastStmt" @@ -3579,7 +3525,7 @@ instance ( exact (BindStmt an pat body) = do debugM $ "BindStmt" pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnLarrow + an0 <- markEpAnnL' an lidl AnnLarrow body' <- markAnnotated body return (BindStmt an0 pat' body') @@ -3593,7 +3539,7 @@ instance ( exact (LetStmt an binds) = do debugM $ "LetStmt" - an0 <- markEpAnnL an lidl AnnLet + an0 <- markEpAnnL' an lidl AnnLet binds' <- markAnnotated binds return (LetStmt an0 binds') @@ -3610,8 +3556,8 @@ instance ( exact (RecStmt an stmts a b c d e) = do debugM $ "RecStmt" - an0 <- markEpAnnL an lal_rest AnnRec - (an1, stmts') <- markAnnList an0 (markAnnotated stmts) + an0 <- markEpAnnL' an lal_rest AnnRec + (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) return (RecStmt an1 stmts' a b c d e) -- --------------------------------------------------------------------- @@ -3624,29 +3570,29 @@ instance ExactPrint (ParStmtBlock GhcPs GhcPs) where return (ParStmtBlock a stmts' b c) exactTransStmt :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm - -> EP w m (EpAnn [AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) + => [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm + -> EP w m ([AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) exactTransStmt an by using ThenForm = do debugM $ "exactTransStmt:ThenForm" - an0 <- markEpAnnL an lidl AnnThen + an0 <- markEpAnnL' an lidl AnnThen using' <- markAnnotated using case by of Nothing -> return (an0, by, using') Just b -> do - an1 <- markEpAnnL an0 lidl AnnBy + an1 <- markEpAnnL' an0 lidl AnnBy b' <- markAnnotated b return (an1, Just b', using') exactTransStmt an by using GroupForm = do debugM $ "exactTransStmt:GroupForm" - an0 <- markEpAnnL an lidl AnnThen - an1 <- markEpAnnL an0 lidl AnnGroup + an0 <- markEpAnnL' an lidl AnnThen + an1 <- markEpAnnL' an0 lidl AnnGroup (an2, by') <- case by of Nothing -> return (an1, by) Just b -> do - an2 <- markEpAnnL an1 lidl AnnBy + an2 <- markEpAnnL' an1 lidl AnnBy b' <- markAnnotated b return (an2, Just b') - an3 <- markEpAnnL an2 lidl AnnUsing + an3 <- markEpAnnL' an2 lidl AnnUsing using' <- markAnnotated using return (an3, by', using') @@ -3666,7 +3612,7 @@ instance ExactPrint (TyClDecl GhcPs) where -- There may be arbitrary parens around parts of the constructor -- that are infix. Turn these into comments so that they feed -- into the right place automatically - an0 <- annotationsToComments' an lidl [AnnOpenP,AnnCloseP] + an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP] an1 <- markEpAnnL' an0 lidl AnnType (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing @@ -3734,7 +3680,7 @@ instance ExactPrint (TyClDecl GhcPs) where tcdDocs = _docs}) where top_matter = do - an' <- annotationsToComments' an lidl [AnnOpenP, AnnCloseP] + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] an0 <- markEpAnnL' an' lidl AnnClass (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context (an1, fds') <- if (null fds) @@ -3750,20 +3696,20 @@ instance ExactPrint (TyClDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (FunDep GhcPs) where - getAnnotationEntry (FunDep an _ _) = fromAnn an - setAnnotationAnchor (FunDep an a b) anc ts cs = FunDep (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (FunDep an ls rs') = do ls' <- markAnnotated ls - an0 <- markEpAnnL an lidl AnnRarrow + an0 <- markEpAnnL' an lidl AnnRarrow rs'' <- markAnnotated rs' return (FunDep an0 ls' rs'') -- --------------------------------------------------------------------- instance ExactPrint (FamilyDecl GhcPs) where - getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an - setAnnotationAnchor x anc ts cs = x { fdExt = setAnchorEpa (fdExt x) anc ts cs} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (FamilyDecl { fdExt = an , fdInfo = info @@ -3782,23 +3728,23 @@ instance ExactPrint (FamilyDecl GhcPs) where case mb_inj of Nothing -> return (an3, mb_inj) Just inj -> do - an4 <- markEpAnnL an3 lidl AnnVbar + an4 <- markEpAnnL' an3 lidl AnnVbar inj' <- markAnnotated inj return (an4, Just inj') (an5, info') <- case info of ClosedTypeFamily mb_eqns -> do - an5 <- markEpAnnL an4 lidl AnnWhere - an6 <- markEpAnnL an5 lidl AnnOpenC + an5 <- markEpAnnL' an4 lidl AnnWhere + an6 <- markEpAnnL' an5 lidl AnnOpenC (an7, mb_eqns') <- case mb_eqns of Nothing -> do - an7 <- markEpAnnL an6 lidl AnnDotdot + an7 <- markEpAnnL' an6 lidl AnnDotdot return (an7, mb_eqns) Just eqns -> do eqns' <- markAnnotated eqns return (an6, Just eqns') - an8 <- markEpAnnL an7 lidl AnnCloseC + an8 <- markEpAnnL' an7 lidl AnnCloseC return (an8, ClosedTypeFamily mb_eqns') _ -> return (an4, info) return (FamilyDecl { fdExt = an5 @@ -3812,30 +3758,30 @@ instance ExactPrint (FamilyDecl GhcPs) where where exact_top_level an' = case top_level of - TopLevel -> markEpAnnL an' lidl AnnFamily + TopLevel -> markEpAnnL' an' lidl AnnFamily NotTopLevel -> do -- It seems that in some kind of legacy -- mode the 'family' keyword is still -- accepted. - markEpAnnL an' lidl AnnFamily + markEpAnnL' an' lidl AnnFamily exact_kind an' = case result of NoSig _ -> return (an', result) KindSig x kind -> do - an0 <- markEpAnnL an' lidl AnnDcolon + an0 <- markEpAnnL' an' lidl AnnDcolon kind' <- markAnnotated kind return (an0, KindSig x kind') TyVarSig x tv_bndr -> do - an0 <- markEpAnnL an' lidl AnnEqual + an0 <- markEpAnnL' an' lidl AnnEqual tv_bndr' <- markAnnotated tv_bndr return (an0, TyVarSig x tv_bndr') -exactFlavour :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EP w m (EpAnn [AddEpAnn]) -exactFlavour an DataFamily = markEpAnnL an lidl AnnData -exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType -exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType +exactFlavour :: (Monad m, Monoid w) => [AddEpAnn] -> FamilyInfo GhcPs -> EP w m [AddEpAnn] +exactFlavour an DataFamily = markEpAnnL' an lidl AnnData +exactFlavour an OpenTypeFamily = markEpAnnL' an lidl AnnType +exactFlavour an (ClosedTypeFamily {}) = markEpAnnL' an lidl AnnType -- --------------------------------------------------------------------- @@ -3857,7 +3803,7 @@ exactDataDefn an exactHdr , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) = do - an' <- annotationsToComments' an lidl [AnnOpenP, AnnCloseP] + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] an0 <- case condecls of DataTypeCons is_type_data _ -> do @@ -3933,12 +3879,12 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context -- --------------------------------------------------------------------- instance ExactPrint (InjectivityAnn GhcPs) where - getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an - setAnnotationAnchor (InjectivityAnn an a b) anc ts cs = InjectivityAnn (setAnchorEpa an anc ts cs) a b + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (InjectivityAnn an lhs rhs) = do - an0 <- markEpAnnL an lidl AnnVbar + an0 <- markEpAnnL' an lidl AnnVbar lhs' <- markAnnotated lhs - an1 <- markEpAnnL an0 lidl AnnRarrow + an1 <- markEpAnnL' an0 lidl AnnRarrow rhs' <- mapM markAnnotated rhs return (InjectivityAnn an1 lhs' rhs') @@ -4148,14 +4094,13 @@ instance ExactPrint (HsForAllTelescope GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (HsDerivingClause GhcPs) where - getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) - setAnnotationAnchor x anc ts cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc ts cs}) - `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs)) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (HsDerivingClause { deriv_clause_ext = an , deriv_clause_strategy = dcs , deriv_clause_tys = dct }) = do - an0 <- markEpAnnL an lidl AnnDeriving + an0 <- markEpAnnL' an lidl AnnDeriving exact_strat_before dct' <- markAnnotated dct exact_strat_after @@ -4171,27 +4116,20 @@ instance ExactPrint (HsDerivingClause GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (DerivStrategy GhcPs) where - getAnnotationEntry (StockStrategy an) = fromAnn an - getAnnotationEntry (AnyclassStrategy an) = fromAnn an - getAnnotationEntry (NewtypeStrategy an) = fromAnn an - getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an - - setAnnotationAnchor (StockStrategy an) anc ts cs = (StockStrategy (setAnchorEpa an anc ts cs)) - setAnnotationAnchor (AnyclassStrategy an) anc ts cs = (AnyclassStrategy (setAnchorEpa an anc ts cs)) - setAnnotationAnchor (NewtypeStrategy an) anc ts cs = (NewtypeStrategy (setAnchorEpa an anc ts cs)) - setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc ts cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc ts cs) a)) + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (StockStrategy an) = do - an0 <- markEpAnnL an lid AnnStock + an0 <- markEpAnnL' an lid AnnStock return (StockStrategy an0) exact (AnyclassStrategy an) = do - an0 <- markEpAnnL an lid AnnAnyclass + an0 <- markEpAnnL' an lid AnnAnyclass return (AnyclassStrategy an0) exact (NewtypeStrategy an) = do - an0 <- markEpAnnL an lid AnnNewtype + an0 <- markEpAnnL' an lid AnnNewtype return (NewtypeStrategy an0) exact (ViaStrategy (XViaStrategyPs an ty)) = do - an0 <- markEpAnnL an lid AnnVia + an0 <- markEpAnnL' an lid AnnVia ty' <- markAnnotated ty return (ViaStrategy (XViaStrategyPs an0 ty')) @@ -4354,11 +4292,8 @@ exact_condecls an cs -- --------------------------------------------------------------------- instance ExactPrint (ConDecl GhcPs) where - getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (snd (con_g_ext x)) - getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) - - setAnnotationAnchor x at ConDeclGADT{} anc ts cs = x { con_g_ext = fmap (\an -> setAnchorEpa an anc ts cs) (con_g_ext x) } - setAnnotationAnchor x at ConDeclH98{} anc ts cs = x { con_ext = setAnchorEpa (con_ext x) anc ts cs} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a -- based on pprConDecl exact (ConDeclH98 { con_ext = an @@ -4369,15 +4304,15 @@ instance ExactPrint (ConDecl GhcPs) where , con_args = args , con_doc = doc }) = do an0 <- if has_forall - then markEpAnnL an lidl AnnForall + then markEpAnnL' an lidl AnnForall else return an ex_tvs' <- mapM markAnnotated ex_tvs an1 <- if has_forall - then markEpAnnL an0 lidl AnnDot + then markEpAnnL' an0 lidl AnnDot else return an0 mcxt' <- mapM markAnnotated mcxt an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow + then markEpAnnL' an1 lidl AnnDarrow else return an1 (con', args') <- exact_details args @@ -4425,7 +4360,7 @@ instance ExactPrint (ConDecl GhcPs) where mcxt' <- mapM markAnnotated mcxt an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow + then markEpAnnL' an1 lidl AnnDarrow else return an1 args' <- case args of @@ -4469,15 +4404,13 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher -- --------------------------------------------------------------------- instance ExactPrint (ConDeclField GhcPs) where - getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) - - setAnnotationAnchor x anc ts cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc ts cs} + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (ConDeclField an names ftype mdoc) = do names' <- markAnnotated names - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon ftype' <- markAnnotated ftype - -- mdoc' <- mapM markAnnotated mdoc return (ConDeclField an0 names' ftype' mdoc) -- --------------------------------------------------------------------- @@ -4617,23 +4550,8 @@ instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where -- ===================================================================== instance ExactPrint (IE GhcPs) where - getAnnotationEntry (IEVar _ _) = NoEntryVal - getAnnotationEntry (IEThingAbs (_, an) _) = fromAnn an - getAnnotationEntry (IEThingAll (_, an) _) = fromAnn an - getAnnotationEntry (IEThingWith (_, an) _ _ _) = fromAnn an - getAnnotationEntry (IEModuleContents (_, an) _)= fromAnn an - getAnnotationEntry (IEGroup _ _ _) = NoEntryVal - getAnnotationEntry (IEDoc _ _) = NoEntryVal - getAnnotationEntry (IEDocNamed _ _) = NoEntryVal - - setAnnotationAnchor a@(IEVar _ _) _ _ _s = a - setAnnotationAnchor (IEThingAbs (depr, an) a) anc ts cs = (IEThingAbs (depr, setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (IEThingAll (depr, an) a) anc ts cs = (IEThingAll (depr, setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (IEThingWith (depr, an) a b c) anc ts cs = (IEThingWith (depr, setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (IEModuleContents (depr, an) a) anc ts cs = (IEModuleContents (depr, setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(IEGroup _ _ _) _ _ _s = a - setAnnotationAnchor a@(IEDoc _ _) _ _ _s = a - setAnnotationAnchor a@(IEDocNamed _ _) _ _ _s = a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (IEVar depr ln) = do depr' <- markAnnotated depr @@ -4646,15 +4564,15 @@ instance ExactPrint (IE GhcPs) where exact (IEThingAll (depr, an) thing) = do depr' <- markAnnotated depr thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnCloseP + an0 <- markEpAnnL' an lidl AnnOpenP + an1 <- markEpAnnL' an0 lidl AnnDotdot + an2 <- markEpAnnL' an1 lidl AnnCloseP return (IEThingAll (depr', an2) thing') exact (IEThingWith (depr, an) thing wc withs) = do depr' <- markAnnotated depr thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP + an0 <- markEpAnnL' an lidl AnnOpenP (an1, wc', withs') <- case wc of NoIEWildcard -> do @@ -4663,16 +4581,16 @@ instance ExactPrint (IE GhcPs) where IEWildcard pos -> do let (bs, as) = splitAt pos withs bs' <- markAnnotated bs - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnComma + an1 <- markEpAnnL' an0 lidl AnnDotdot + an2 <- markEpAnnL' an1 lidl AnnComma as' <- markAnnotated as return (an2, wc, bs'++as') - an2 <- markEpAnnL an1 lidl AnnCloseP + an2 <- markEpAnnL' an1 lidl AnnCloseP return (IEThingWith (depr', an2) thing' wc' withs') exact (IEModuleContents (depr, an) m) = do depr' <- markAnnotated depr - an0 <- markEpAnnL an lidl AnnModule + an0 <- markEpAnnL' an lidl AnnModule m' <- markAnnotated m return (IEModuleContents (depr', an0) m') @@ -4706,41 +4624,8 @@ instance ExactPrint (IEWrappedName GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (Pat GhcPs) where - getAnnotationEntry (WildPat _) = NoEntryVal - getAnnotationEntry (VarPat _ _) = NoEntryVal - getAnnotationEntry (LazyPat an _) = fromAnn an - getAnnotationEntry (AsPat _ _ _) = NoEntryVal - getAnnotationEntry (ParPat _ _) = NoEntryVal - getAnnotationEntry (BangPat an _) = fromAnn an - getAnnotationEntry (ListPat an _) = fromAnn an - getAnnotationEntry (TuplePat an _ _) = fromAnn an - getAnnotationEntry (SumPat an _ _ _) = fromAnn an - getAnnotationEntry (ConPat an _ _) = fromAnn an - getAnnotationEntry (ViewPat an _ _) = fromAnn an - getAnnotationEntry (SplicePat _ _) = NoEntryVal - getAnnotationEntry (LitPat _ _) = NoEntryVal - getAnnotationEntry (NPat an _ _ _) = fromAnn an - getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an - getAnnotationEntry (SigPat an _ _) = fromAnn an - getAnnotationEntry (EmbTyPat _ _) = NoEntryVal - - setAnnotationAnchor a@(WildPat _) _ _ _s = a - setAnnotationAnchor a@(VarPat _ _) _ _ _s = a - setAnnotationAnchor (LazyPat an a) anc ts cs = (LazyPat (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor a@(AsPat _ _ _) _ _ _s = a - setAnnotationAnchor a@(ParPat _ _) _ _ _s = a - setAnnotationAnchor (BangPat an a) anc ts cs = (BangPat (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (ListPat an a) anc ts cs = (ListPat (setAnchorEpa an anc ts cs) a) - setAnnotationAnchor (TuplePat an a b) anc ts cs = (TuplePat (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (SumPat an a b c) anc ts cs = (SumPat (setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (ConPat an a b) anc ts cs = (ConPat (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor (ViewPat an a b) anc ts cs = (ViewPat (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(SplicePat _ _) _ _ _s = a - setAnnotationAnchor a@(LitPat _ _) _ _ _s = a - setAnnotationAnchor (NPat an a b c) anc ts cs = (NPat (setAnchorEpa an anc ts cs) a b c) - setAnnotationAnchor (NPlusKPat an a b c d e) anc ts cs = (NPlusKPat (setAnchorEpa an anc ts cs) a b c d e) - setAnnotationAnchor (SigPat an a b) anc ts cs = (SigPat (setAnchorEpa an anc ts cs) a b) - setAnnotationAnchor a@(EmbTyPat _ _) _ _ _s = a + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a exact (WildPat w) = do anchor' <- getAnchorU @@ -4756,7 +4641,7 @@ instance ExactPrint (Pat GhcPs) where else return n return (VarPat x n') exact (LazyPat an pat) = do - an0 <- markEpAnnL an lidl AnnTilde + an0 <- markEpAnnL' an lidl AnnTilde pat' <- markAnnotated pat return (LazyPat an0 pat') exact (AsPat at n pat) = do @@ -4771,30 +4656,30 @@ instance ExactPrint (Pat GhcPs) where return (ParPat (lpar', rpar') pat') exact (BangPat an pat) = do - an0 <- markEpAnnL an lidl AnnBang + an0 <- markEpAnnL' an lidl AnnBang pat' <- markAnnotated pat return (BangPat an0 pat') exact (ListPat an pats) = do - (an', pats') <- markAnnList an (markAnnotated pats) + (an', pats') <- markAnnList' an (markAnnotated pats) return (ListPat an' pats') exact (TuplePat an pats boxity) = do an0 <- case boxity of - Boxed -> markEpAnnL an lidl AnnOpenP - Unboxed -> markEpAnnL an lidl AnnOpenPH + Boxed -> markEpAnnL' an lidl AnnOpenP + Unboxed -> markEpAnnL' an lidl AnnOpenPH pats' <- markAnnotated pats an1 <- case boxity of - Boxed -> markEpAnnL an0 lidl AnnCloseP - Unboxed -> markEpAnnL an0 lidl AnnClosePH + Boxed -> markEpAnnL' an0 lidl AnnCloseP + Unboxed -> markEpAnnL' an0 lidl AnnClosePH return (TuplePat an1 pats' boxity) exact (SumPat an pat alt arity) = do - an0 <- markEpAnnL an lsumPatParens AnnOpenPH + an0 <- markEpAnnL' an lsumPatParens AnnOpenPH an1 <- markAnnKwAllL an0 lsumPatVbarsBefore AnnVbar pat' <- markAnnotated pat an2 <- markAnnKwAllL an1 lsumPatVbarsAfter AnnVbar - an3 <- markEpAnnL an2 lsumPatParens AnnClosePH + an3 <- markEpAnnL' an2 lsumPatParens AnnClosePH return (SumPat an3 pat' alt arity) exact (ConPat an con details) = do @@ -4802,7 +4687,7 @@ instance ExactPrint (Pat GhcPs) where return (ConPat an' con' details') exact (ViewPat an expr pat) = do expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnRarrow + an0 <- markEpAnnL' an lidl AnnRarrow pat' <- markAnnotated pat return (ViewPat an0 expr' pat') exact (SplicePat x splice) = do @@ -4811,7 +4696,7 @@ instance ExactPrint (Pat GhcPs) where exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p exact (NPat an ol mn z) = do an0 <- if (isJust mn) - then markEpAnnL an lidl AnnMinus + then markEpAnnL' an lidl AnnMinus else return an ol' <- markAnnotated ol return (NPat an0 ol' mn z) @@ -4824,7 +4709,7 @@ instance ExactPrint (Pat GhcPs) where exact (SigPat an pat sig) = do pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnDcolon + an0 <- markEpAnnL' an lidl AnnDcolon sig' <- markAnnotated sig return (SigPat an0 pat' sig') @@ -4903,8 +4788,8 @@ sourceTextToString (SourceText txt) _ = unpackFS txt -- --------------------------------------------------------------------- exactUserCon :: (Monad m, Monoid w, ExactPrint con) - => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs - -> EP w m (EpAnn [AddEpAnn], con, HsConPatDetails GhcPs) + => [AddEpAnn] -> con -> HsConPatDetails GhcPs + -> EP w m ([AddEpAnn], con, HsConPatDetails GhcPs) exactUserCon an c (InfixCon p1 p2) = do p1' <- markAnnotated p1 c' <- markAnnotated c @@ -4912,9 +4797,9 @@ exactUserCon an c (InfixCon p1 p2) = do return (an, c', InfixCon p1' p2') exactUserCon an c details = do c' <- markAnnotated c - an0 <- markEpAnnL an lidl AnnOpenC + an0 <- markEpAnnL' an lidl AnnOpenC details' <- exactConArgs details - an1 <- markEpAnnL an0 lidl AnnCloseC + an1 <- markEpAnnL' an0 lidl AnnCloseC return (an1, c', details') instance ExactPrint (HsConPatTyArg GhcPs) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad7a0bb4eaffd664d4c613b18b23b61750b533f1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad7a0bb4eaffd664d4c613b18b23b61750b533f1 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 Dec 13 21:39:25 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 16:39:25 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: rts/eventlog: Fix off-by-one in assertion Message-ID: <657a248d66e5b_2e72b3bbb75501296ee@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 8a9c3365 by Bryan Richter at 2023-12-13T16:39:15-05:00 Document ghc package's PVP-noncompliance This changes nothing, it just makes the status quo explicit. - - - - - ed75a263 by Luite Stegeman at 2023-12-13T16:39:21-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 - - - - - 30 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0a9fa9df578ec1ac840597d1ab60571d5c98b2ac...ed75a26347ec2ef1ab2824c184d11ef6e1d9d588 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0a9fa9df578ec1ac840597d1ab60571d5c98b2ac...ed75a26347ec2ef1ab2824c184d11ef6e1d9d588 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 Dec 13 21:47:50 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:47:50 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657a2686b1eda_2e72b3becc7cc1348a8@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: 1294ca4d by Ben Gamari at 2023-12-13T16:47:16-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. - - - - - 20 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/rts/TSANUtils.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld![(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld![(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif ===================================== rts/include/rts/TSANUtils.h ===================================== @@ -73,6 +73,7 @@ #endif #endif +#if !defined(CMINUSMINUS) #if defined(TSAN_ENABLED) #if !defined(HAVE_C11_ATOMICS) #error TSAN cannot be enabled without C11 atomics support. @@ -106,3 +107,4 @@ uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, ui uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); +#endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1294ca4dbad45a22ba4a596c6264b825721c6eea -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1294ca4dbad45a22ba4a596c6264b825721c6eea 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 Dec 13 21:48:27 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:48:27 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 17 commits: Fix thunk update ordering Message-ID: <657a26abaada9_2e72b3bed45801356e7@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 1294ca4d by Ben Gamari at 2023-12-13T16:47:16-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. - - - - - 3255a411 by Ben Gamari at 2023-12-13T16:48:16-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - c517fa05 by Ben Gamari at 2023-12-13T16:48:16-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - c5f90624 by Ben Gamari at 2023-12-13T16:48:16-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 01f9bcaf by Ben Gamari at 2023-12-13T16:48:16-05:00 rts: Fix data race in Interpreter's preemption check - - - - - a978a196 by Ben Gamari at 2023-12-13T16:48:16-05:00 rts: Fix data race in threadStatus# - - - - - 4a314016 by Ben Gamari at 2023-12-13T16:48:16-05:00 base: use atomic write when updating timer manager - - - - - 62ba04c8 by Ben Gamari at 2023-12-13T16:48:16-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - 69342b8d by Ben Gamari at 2023-12-13T16:48:16-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - e10b2534 by Ben Gamari at 2023-12-13T16:48:16-05:00 rts: Fix synchronization on thread blocking state - - - - - 9195ce12 by Ben Gamari at 2023-12-13T16:48:17-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 5a1aabd6 by Ben Gamari at 2023-12-13T16:48:17-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - df401a4b by Ben Gamari at 2023-12-13T16:48:17-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 560b9cf1 by Ben Gamari at 2023-12-13T16:48:17-05:00 rts/Messages: Fix data race - - - - - bc6273de by Ben Gamari at 2023-12-13T16:48:17-05:00 rts/Prof: Fix data race - - - - - 5614e1a3 by Ben Gamari at 2023-12-13T16:48:17-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - dd93ee4a by Ben Gamari at 2023-12-13T16:48:17-05:00 rts: Fix data races in profiling timer - - - - - 30 changed files: - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/base/src/GHC/Event/Thread.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Exception.cmm - rts/Heap.c - rts/HeapStackCheck.cmm - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/849b8b0de53f327d00479f994b816618423c5e40...dd93ee4acfe088b82d9587b1a5b577e59197ceec -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/849b8b0de53f327d00479f994b816618423c5e40...dd93ee4acfe088b82d9587b1a5b577e59197ceec 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 Dec 13 21:54:46 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:54:46 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657a28264ac31_2e72b3c290bd8136322@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: c1767fa7 by Ben Gamari at 2023-12-13T16:54: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. - - - - - 20 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/rts/TSANUtils.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld[(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld[(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif ===================================== rts/include/rts/TSANUtils.h ===================================== @@ -73,6 +73,7 @@ #endif #endif +#if !defined(CMINUSMINUS) #if defined(TSAN_ENABLED) #if !defined(HAVE_C11_ATOMICS) #error TSAN cannot be enabled without C11 atomics support. @@ -106,3 +107,4 @@ uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, ui uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); +#endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1767fa7d745e5f3a234c0584ea9e4860018cfe0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1767fa7d745e5f3a234c0584ea9e4860018cfe0 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 Dec 13 21:55:48 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Wed, 13 Dec 2023 16:55:48 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 17 commits: Fix thunk update ordering Message-ID: <657a2863ee3e4_2e72b3c6200281369c2@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: c1767fa7 by Ben Gamari at 2023-12-13T16:54: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. - - - - - bcb8dafc by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - 0b99afb8 by Ben Gamari at 2023-12-13T16:55:36-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - 755f66bb by Ben Gamari at 2023-12-13T16:55:36-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 78126ba5 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Fix data race in Interpreter's preemption check - - - - - 06f3207a by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Fix data race in threadStatus# - - - - - 6e6174cf by Ben Gamari at 2023-12-13T16:55:36-05:00 base: use atomic write when updating timer manager - - - - - 972216f9 by Ben Gamari at 2023-12-13T16:55:36-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - f2d5acca by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - 3302cbb1 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Fix synchronization on thread blocking state - - - - - 1d3649e1 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - b0fcd1ba by Ben Gamari at 2023-12-13T16:55:36-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 2e190915 by Ben Gamari at 2023-12-13T16:55:36-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 740c3e62 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts/Messages: Fix data race - - - - - 42cc9534 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts/Prof: Fix data race - - - - - 8697403c by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - a5d03211 by Ben Gamari at 2023-12-13T16:55:36-05:00 rts: Fix data races in profiling timer - - - - - 30 changed files: - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/base/src/GHC/Event/Thread.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Exception.cmm - rts/Heap.c - rts/HeapStackCheck.cmm - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd93ee4acfe088b82d9587b1a5b577e59197ceec...a5d0321143668d95bd74549c541bcddb32dcbc13 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dd93ee4acfe088b82d9587b1a5b577e59197ceec...a5d0321143668d95bd74549c541bcddb32dcbc13 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 Dec 14 01:50:07 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Wed, 13 Dec 2023 20:50:07 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Document ghc package's PVP-noncompliance Message-ID: <657a5f4f8a3d8_2e72b311ef7778148925@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 76c5aee9 by Bryan Richter at 2023-12-13T20:49:58-05:00 Document ghc package's PVP-noncompliance This changes nothing, it just makes the status quo explicit. - - - - - 0de93194 by Luite Stegeman at 2023-12-13T20:50:01-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 - - - - - 10 changed files: - compiler/ghc.cabal.in - libraries/base/tests/all.T - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/T20509/all.T - testsuite/tests/backpack/cabal/bkpcabal02/all.T - testsuite/tests/backpack/cabal/bkpcabal03/all.T - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/rts/all.T Changes: ===================================== compiler/ghc.cabal.in ===================================== @@ -20,6 +20,11 @@ Description: . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom ===================================== libraries/base/tests/all.T ===================================== @@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', omit_ghci, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) -test('AtomicModifyIORef', normal, compile_and_run, ['']) +test('AtomicModifyIORef', js_fragile(24259), compile_and_run, ['']) test('AtomicSwapIORef', normal, compile_and_run, ['']) test('T23454', normal, compile_fail, ['']) test('T23687', normal, compile_and_run, ['']) ===================================== testsuite/driver/testlib.py ===================================== @@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ): else: return normal; +# expect occasional failures for the JS backend +def js_fragile( bug: IssueNumber ): + if js_arch(): + return fragile(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the ===================================== testsuite/tests/backpack/cabal/T20509/all.T ===================================== @@ -1,6 +1,7 @@ test('T20509', [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) , run_timeout_multiplier(2) + , js_fragile(24259) ], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal02/all.T ===================================== @@ -1,5 +1,6 @@ test('bkpcabal02', [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), - normalise_version('bkpcabal01')], + normalise_version('bkpcabal01'), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal03/all.T ===================================== @@ -1,4 +1,5 @@ test('bkpcabal03', - [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])], + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'), # times out with ghci test('T4030', omit_ghci, compile_and_run, ['-O']) -test('throwto002', normal, compile_and_run, ['']) +test('throwto002', js_fragile(24259), compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2))) test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_fragile(24259) ], compile_and_run, ['-package ghc -package exceptions']) ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) -test('T22671', normal, compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers']) +test('T22671', js_fragile(24259), compile_and_run, ['']) +test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers']) test('T24066', normal, compile_and_run, ['']) ===================================== testsuite/tests/rts/all.T ===================================== @@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip) , omit_ghci , req_th , when(platform('x86_64-unknown-linux'), fragile(22283)) + , js_fragile(24259) ] , compile_and_run, [config.ghc_th_way_flags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed75a26347ec2ef1ab2824c184d11ef6e1d9d588...0de9319433e80ae05fe83229fc061052dea1b3f8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ed75a26347ec2ef1ab2824c184d11ef6e1d9d588...0de9319433e80ae05fe83229fc061052dea1b3f8 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 Dec 14 04:38:00 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Wed, 13 Dec 2023 23:38:00 -0500 Subject: [Git][ghc/ghc][wip/expand-do] 63 commits: testsuite: Add mechanism to collect generic metrics Message-ID: <657a86a8c52ce_2e72b31609ca5c1648e0@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 38d2861d by Apoorv Ingle at 2023-12-13T16:56:12-06:00 Expand `do` blocks right before typechecking using the `HsExpansion` philosophy. - A step towards killing `tcSyntaxOp` - Fixes #18324 #20020 #23147 #22788 #15598 #22086 #21206 - Note [Expanding HsDo with HsExpansion] in `GHC.Tc.Gen.Do` explains change in detail - Note Note [Doing HsExpansion in the Renamer vs Typechecker] in `GHC.Rename.Expr` expains the rational of doing expansions in type checker as opposed to in the renamer - New datatype to make this expansion work `GHC.Hs.Expr.XXExprGhcRn`: 1. Expansion bits for Expressions, Statements and Patterns in (`ExpandedThingRn`) 2. `PopErrCtxt` a special GhcRn Phase only artifcat to pop the previous error message in the error context stack - Kills `HsExpansion` and `HsExpanded` as we have inlined them in `XXExprGhcRn` and `XXExprGhcTc` - `GHC.Basic.Origin` now tracks the reason for expansion in case of Generated This is useful for type checking cf. `GHC.Tc.Gen.Expr.tcExpr` case for `HsLam` - Ensures warnings such as 1. Pattern mach checks 2. Failable patterns 3. non-() return in body statements are preserved - Expansions inside Template haskell also work without issues. - Kill `HsMatchCtxt` in favor of `TcMatchAltChecker` - Make records Expand and not desugar before typechecking. - Testcases: * T18324 T20020 T23147 T22788 T15598 T22086 * T23147b (error message check), * DoubleMatch (match inside a match for pmc check) * pattern-fails (check pattern match with non-refutable pattern, eg. newtype) * Simple-rec (rec statements inside do statment) * T22788 (code snippet from #22788) * DoExpanion1 (Error messages for body statments) * DoExpansion2 (Error messages for bind statements) * DoExpansion3 (Error messages for let statements) - - - - - 3d3affa3 by Apoorv Ingle at 2023-12-13T16:56:18-06:00 - Renaming `GHC.Types.Basic.{Origin -> MatchOrigin}` - - - - - c0aa4738 by Apoorv Ingle at 2023-12-13T16:56:18-06:00 - hpc ticks, Do not count pattern match failures, update hpc tests - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/Lexer.x - compiler/GHC/CmmToLlvm/Data.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05bcf82551f360249839517a804970e0635718b3...c0aa47388a33928fc2fea7926327d31c80303e15 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/05bcf82551f360249839517a804970e0635718b3...c0aa47388a33928fc2fea7926327d31c80303e15 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 Dec 14 07:21:00 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 14 Dec 2023 02:21:00 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Document ghc package's PVP-noncompliance Message-ID: <657aacdc5b85b_2e72b319d23ed017733b@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: e39e9b8f by Bryan Richter at 2023-12-14T02:20:46-05:00 Document ghc package's PVP-noncompliance This changes nothing, it just makes the status quo explicit. - - - - - 31360c80 by Luite Stegeman at 2023-12-14T02:20:48-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 - - - - - 10 changed files: - compiler/ghc.cabal.in - libraries/base/tests/all.T - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/T20509/all.T - testsuite/tests/backpack/cabal/bkpcabal02/all.T - testsuite/tests/backpack/cabal/bkpcabal03/all.T - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/rts/all.T Changes: ===================================== compiler/ghc.cabal.in ===================================== @@ -20,6 +20,11 @@ Description: . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom ===================================== libraries/base/tests/all.T ===================================== @@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', omit_ghci, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) -test('AtomicModifyIORef', normal, compile_and_run, ['']) +test('AtomicModifyIORef', js_fragile(24259), compile_and_run, ['']) test('AtomicSwapIORef', normal, compile_and_run, ['']) test('T23454', normal, compile_fail, ['']) test('T23687', normal, compile_and_run, ['']) ===================================== testsuite/driver/testlib.py ===================================== @@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ): else: return normal; +# expect occasional failures for the JS backend +def js_fragile( bug: IssueNumber ): + if js_arch(): + return fragile(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the ===================================== testsuite/tests/backpack/cabal/T20509/all.T ===================================== @@ -1,6 +1,7 @@ test('T20509', [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) , run_timeout_multiplier(2) + , js_fragile(24259) ], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal02/all.T ===================================== @@ -1,5 +1,6 @@ test('bkpcabal02', [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), - normalise_version('bkpcabal01')], + normalise_version('bkpcabal01'), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal03/all.T ===================================== @@ -1,4 +1,5 @@ test('bkpcabal03', - [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])], + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'), # times out with ghci test('T4030', omit_ghci, compile_and_run, ['-O']) -test('throwto002', normal, compile_and_run, ['']) +test('throwto002', js_fragile(24259), compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2))) test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_fragile(24259) ], compile_and_run, ['-package ghc -package exceptions']) ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) -test('T22671', normal, compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers']) +test('T22671', js_fragile(24259), compile_and_run, ['']) +test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers']) test('T24066', normal, compile_and_run, ['']) ===================================== testsuite/tests/rts/all.T ===================================== @@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip) , omit_ghci , req_th , when(platform('x86_64-unknown-linux'), fragile(22283)) + , js_fragile(24259) ] , compile_and_run, [config.ghc_th_way_flags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0de9319433e80ae05fe83229fc061052dea1b3f8...31360c805ea46423f3db0f7287bb2d4225f06d5b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0de9319433e80ae05fe83229fc061052dea1b3f8...31360c805ea46423f3db0f7287bb2d4225f06d5b 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 Dec 14 09:31:27 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 14 Dec 2023 04:31:27 -0500 Subject: [Git][ghc/ghc][master] Document ghc package's PVP-noncompliance Message-ID: <657acb6edbaaf_2e72b31d029050200396@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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. - - - - - 1 changed file: - compiler/ghc.cabal.in Changes: ===================================== compiler/ghc.cabal.in ===================================== @@ -20,6 +20,11 @@ Description: . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed0e4099525b400a330b34554825f7f90d007eee -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed0e4099525b400a330b34554825f7f90d007eee 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 Dec 14 09:31:59 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Thu, 14 Dec 2023 04:31:59 -0500 Subject: [Git][ghc/ghc][master] JS: Mark spurious CI failures js_fragile(24259) Message-ID: <657acb8f7bde1_2e72b31d0261c0203436@gitlab.mail> Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 9 changed files: - libraries/base/tests/all.T - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/T20509/all.T - testsuite/tests/backpack/cabal/bkpcabal02/all.T - testsuite/tests/backpack/cabal/bkpcabal03/all.T - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/rts/all.T Changes: ===================================== libraries/base/tests/all.T ===================================== @@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', omit_ghci, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) -test('AtomicModifyIORef', normal, compile_and_run, ['']) +test('AtomicModifyIORef', js_fragile(24259), compile_and_run, ['']) test('AtomicSwapIORef', normal, compile_and_run, ['']) test('T23454', normal, compile_fail, ['']) test('T23687', normal, compile_and_run, ['']) ===================================== testsuite/driver/testlib.py ===================================== @@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ): else: return normal; +# expect occasional failures for the JS backend +def js_fragile( bug: IssueNumber ): + if js_arch(): + return fragile(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the ===================================== testsuite/tests/backpack/cabal/T20509/all.T ===================================== @@ -1,6 +1,7 @@ test('T20509', [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) , run_timeout_multiplier(2) + , js_fragile(24259) ], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal02/all.T ===================================== @@ -1,5 +1,6 @@ test('bkpcabal02', [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), - normalise_version('bkpcabal01')], + normalise_version('bkpcabal01'), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal03/all.T ===================================== @@ -1,4 +1,5 @@ test('bkpcabal03', - [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])], + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'), # times out with ghci test('T4030', omit_ghci, compile_and_run, ['-O']) -test('throwto002', normal, compile_and_run, ['']) +test('throwto002', js_fragile(24259), compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2))) test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_fragile(24259) ], compile_and_run, ['-package ghc -package exceptions']) ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) -test('T22671', normal, compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers']) +test('T22671', js_fragile(24259), compile_and_run, ['']) +test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers']) test('T24066', normal, compile_and_run, ['']) ===================================== testsuite/tests/rts/all.T ===================================== @@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip) , omit_ghci , req_th , when(platform('x86_64-unknown-linux'), fragile(22283)) + , js_fragile(24259) ] , compile_and_run, [config.ghc_th_way_flags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bef8d9ff72ca826338e2e893b0d97bfc7b25d0b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bef8d9ff72ca826338e2e893b0d97bfc7b25d0b 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 Dec 14 09:35:56 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 04:35:56 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/24249 Message-ID: <657acc7c5873b_2e72b31cc3dec82036c8@gitlab.mail> Zubin pushed new branch wip/24249 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24249 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 Dec 14 09:37:01 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 04:37:01 -0500 Subject: [Git][ghc/ghc][wip/24249] docs: document permissibility of -XOverloadedLabels (#24249) Message-ID: <657accbdde90d_2e72b31d01d3e02055ec@gitlab.mail> Zubin pushed to branch wip/24249 at Glasgow Haskell Compiler / GHC Commits: b55c9aad by Zubin Duggal at 2023-12-14T15:06:44+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 - - - - - 1 changed file: - docs/users_guide/exts/overloaded_labels.rst Changes: ===================================== 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. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b55c9aad56d2e1c4c9c4f9585f6228aa44c710f8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b55c9aad56d2e1c4c9c4f9585f6228aa44c710f8 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 Dec 14 09:44:26 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 04:44:26 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 13 commits: Fix unusable units and module reexport interaction (#21097) Message-ID: <657ace7a9e7b2_2e72b31dd33a0c205820@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 4b3c06cd by Sylvain Henry at 2023-12-14T14:00:30+05:30 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. (cherry picked from commit cee81370cd6ef256f66035e3116878d4cb82e28b) - - - - - 52b3886a by Zubin Duggal at 2023-12-14T14:03:48+05:30 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 (cherry picked from commit fa148f6ed43f915f2ae40302dda1b8bae39512af) - - - - - 9e2a2c47 by Zubin Duggal at 2023-12-14T14:03:56+05:30 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 (cherry picked from commit a62d4cb25b805dd7e12476db97a667fd542ea006) - - - - - 1d381ec6 by Zubin Duggal at 2023-12-14T14:04:03+05:30 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 (cherry picked from commit 244d3315352376eb7b946843fb0c512412842d7d) - - - - - 87bdf022 by Zubin Duggal at 2023-12-14T14:06:14+05:30 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 (cherry picked from commit 306cb4e3e02e466f6c5a57c1a65fd2a5d13b3f89) - - - - - 726603c6 by Zubin Duggal at 2023-12-14T14:19:29+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. (cherry picked from commit 77a3b580f561e62f5ac7ebf6588199575aafd3b4) - - - - - bc0c7d79 by Pierre Le Marre at 2023-12-14T14:22:50+05:30 Update to Unicode 15.1.0 See: https://www.unicode.org/versions/Unicode15.1.0/ (cherry picked from commit 778c84b61679a8bb9dd83e2c41156abc0f39abd3) - - - - - 0d9c8f18 by Simon Peyton Jones at 2023-12-14T14:29:37+05:30 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 (cherry picked from commit 6dbab1808bfbe484b3fb396aab1d105314f918d8) - - - - - a07dd65e by Simon Peyton Jones at 2023-12-14T14:49:23+05:30 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] (cherry picked from commit 2776920e642544477a38d0ed9205d4f0b48a782e) - - - - - 0f0111d5 by Zubin Duggal at 2023-12-14T15:11:19+05:30 Bump array submodule to 0.5.6.0 - - - - - 5be50e5a by Matthew Pickering at 2023-12-14T15:13:53+05:30 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 (cherry picked from commit 36b9a38cc45a26865c4e45f4949e519a5dede76d) - - - - - a7841019 by Matthew Pickering at 2023-12-14T15:14:03+05:30 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 (cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a) - - - - - 540c96eb by Zubin Duggal at 2023-12-14T15:14:15+05:30 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 (cherry picked from commit 86f652dc9a649e59e643609c287a510a565f5408) - - - - - 30 changed files: - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Unit/State.hs - hadrian/src/Settings/Warnings.hs - libraries/array - libraries/base/GHC/Unicode/Internal/Char/DerivedCoreProperties.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/GeneralCategory.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Version.hs - libraries/base/changelog.md - libraries/base/tests/unicode003.stdout - libraries/base/tools/ucd2haskell/ucd.sh - libraries/base/tools/ucd2haskell/unicode_version - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aee7728acd04eecf12f1e3411dfb50e4e86b33eb...540c96eb7af7cbca4673a51b9a19498247a2e6ed -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aee7728acd04eecf12f1e3411dfb50e4e86b33eb...540c96eb7af7cbca4673a51b9a19498247a2e6ed 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 Dec 14 09:55:03 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 04:55:03 -0500 Subject: =?UTF-8?Q?[Git][ghc/ghc][wip/9.6.4-backports]_5_commits:?= =?UTF-8?Q?_Don=E2=80=99t_store_the_async_exception_masking_state_in_CATCH?= =?UTF-8?Q?_frames?= Message-ID: <657ad0f79e06e_2e72b31e15a4002082f5@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: ac7978ae by Alexis King at 2023-12-14T15:24:49+05:30 Don’t store the async exception masking state in CATCH frames (cherry picked from commit 8b61dfd6dfc78bfa6bb9449dac9a336e5d668b5e) (cherry picked from commit e538003c33251c5c843cac1e30b36f88bb859778) - - - - - 9b3ae2a6 by Zubin Duggal at 2023-12-14T15:24:49+05:30 Bump array submodule to 0.5.6.0 - - - - - 812a8693 by Matthew Pickering at 2023-12-14T15:24:49+05:30 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 (cherry picked from commit 36b9a38cc45a26865c4e45f4949e519a5dede76d) - - - - - 6e841b31 by Matthew Pickering at 2023-12-14T15:24:49+05:30 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 (cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a) - - - - - 821bddbb by Zubin Duggal at 2023-12-14T15:24:49+05:30 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 (cherry picked from commit 86f652dc9a649e59e643609c287a510a565f5408) - - - - - 15 changed files: - hadrian/src/Settings/Warnings.hs - libraries/array - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - rts/Continuation.c - rts/Exception.cmm - rts/RaiseAsync.c - rts/Schedule.c - rts/include/rts/storage/Closures.h - + testsuite/tests/rts/continuations/T23513.hs - + testsuite/tests/rts/continuations/T23513.stdout - testsuite/tests/rts/continuations/all.T - utils/deriveConstants/Main.hs Changes: ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -30,7 +30,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" @@ -53,5 +55,7 @@ ghcWarningsArgs = do , "-Wno-redundant-constraints" , "-Wno-orphans" ] , package unix ? pure [ "-Wno-deprecations" ] - , package win32 ? pure [ "-Wno-trustworthy-safe" ] + , package win32 ? pure [ "-Wno-trustworthy-safe" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] ===================================== libraries/array ===================================== @@ -1 +1 @@ -Subproject commit f487b8de85f2b271a3831c14ab6439b9bc9b8343 +Subproject commit 0daca5dfa33d6c522e9fb8e94a2b66a5ed658c20 ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4 +Subproject commit cdb5171f7774569b1a8028a78392cfa79f732b5c ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit 720debbf5b89366007bac473e8d7fd18e4114f1a +Subproject commit 0b3dbc9901fdf2d752c4ee7a7cee7b1ed20e76bd ===================================== linters/lint-submodule-refs/Main.hs ===================================== @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return True + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return False if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + ===================================== linters/linters-common/Linters/Common.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception ===================================== rts/Continuation.c ===================================== @@ -374,12 +374,12 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT // 1. We walk the stack to find the prompt frame to capture up to (if any). // // 2. If we successfully find a matching prompt, we proceed with the actual - // by allocating space for the continuation, performing the necessary - // copying, and unwinding the stack. + // capture by allocating space for the continuation, performing the + // necessary copying, and unwinding the stack. // // These variables are modified in Phase 1 to keep track of how far we had to // walk before finding the prompt frame. Afterwards, Phase 2 consults them to - // determine how to proceed with the actual capture. + // determine how to proceed. StgWord total_words = 0; bool in_first_chunk = true; ===================================== rts/Exception.cmm ===================================== @@ -393,16 +393,14 @@ stg_killMyself * kind of return to the activation record underneath us on the stack. */ -#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,exceptions_blocked,handler) \ +#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,handler) \ w_ info_ptr, \ PROF_HDR_FIELDS(w_,p1,p2) \ - w_ exceptions_blocked, \ p_ handler INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, - CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2, - exceptions_blocked,handler)) + CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,handler)) return (P_ ret) { return (ret); @@ -411,12 +409,7 @@ INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, stg_catchzh ( P_ io, /* :: IO a */ P_ handler /* :: Exception -> IO a */ ) { - W_ exceptions_blocked; - STK_CHK_GEN(); - - exceptions_blocked = - TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE); TICK_CATCHF_PUSHED(); /* Apply R1 to the realworld token */ @@ -424,8 +417,7 @@ stg_catchzh ( P_ io, /* :: IO a */ TICK_SLOW_CALL_fast_v(); jump stg_ap_v_fast - (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, - exceptions_blocked, handler)) + (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, handler)) (io); } @@ -599,26 +591,28 @@ retry_pop_stack: frame = Sp; if (frame_type == CATCH_FRAME) { + // Note: if this branch is updated, there is a good chance that + // corresponding logic in `raiseAsync` must be updated to match! + // See Note [Apply the handler directly in raiseAsync] in RaiseAsync.c. + Sp = Sp + SIZEOF_StgCatchFrame; - if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) { + + W_ flags; + flags = TO_W_(StgTSO_flags(CurrentTSO)); + if ((flags & TSO_BLOCKEX) == 0) { Sp_adj(-1); Sp(0) = stg_unmaskAsyncExceptionszh_ret_info; } /* Ensure that async exceptions are masked when running the handler. - */ - StgTSO_flags(CurrentTSO) = %lobits32( - TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE); - - /* The interruptible state is inherited from the context of the + * + * The interruptible state is inherited from the context of the * catch frame, but note that TSO_INTERRUPTIBLE is only meaningful * if TSO_BLOCKEX is set. (we got this wrong earlier, and #4988 * was a symptom of the bug). */ - if ((StgCatchFrame_exceptions_blocked(frame) & - (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) == TSO_BLOCKEX) { - StgTSO_flags(CurrentTSO) = %lobits32( - TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE); + if ((flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) { + StgTSO_flags(CurrentTSO) = %lobits32(flags | TSO_BLOCKEX | TSO_INTERRUPTIBLE); } } else /* CATCH_STM_FRAME */ ===================================== rts/RaiseAsync.c ===================================== @@ -950,44 +950,36 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, case CATCH_FRAME: // If we find a CATCH_FRAME, and we've got an exception to raise, - // then build the THUNK raise(exception), and leave it on - // top of the CATCH_FRAME ready to enter. - // + // then set up the top of the stack to apply the handler; + // see Note [Apply the handler directly in raiseAsync]. { - StgCatchFrame *cf = (StgCatchFrame *)frame; - StgThunk *raise; - if (exception == NULL) break; - // we've got an exception to raise, so let's pass it to the - // handler in this frame. - // - raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1); - TICK_ALLOC_SE_THK(WDS(1),0); - SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs); - raise->payload[0] = exception; + StgClosure *handler = ((StgCatchFrame *)frame)->handler; - // throw away the stack from Sp up to the CATCH_FRAME. - // - sp = frame - 1; - - /* Ensure that async exceptions are blocked now, so we don't get - * a surprise exception before we get around to executing the - * handler. - */ - tso->flags |= TSO_BLOCKEX; - if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) { - tso->flags &= ~TSO_INTERRUPTIBLE; - } else { - tso->flags |= TSO_INTERRUPTIBLE; + // Throw away the stack from Sp up to and including the CATCH_FRAME. + sp = frame + stack_frame_sizeW((StgClosure *)frame); + + // Unmask async exceptions after running the handler, if necessary. + if ((tso->flags & TSO_BLOCKEX) == 0) { + sp--; + sp[0] = (W_)&stg_unmaskAsyncExceptionszh_ret_info; } - /* Put the newly-built THUNK on top of the stack, ready to execute - * when the thread restarts. - */ - sp[0] = (W_)raise; - sp[-1] = (W_)&stg_enter_info; - stack->sp = sp-1; + // Ensure that async exceptions are masked while running the handler; + // see Note [Apply the handler directly in raiseAsync]. + if ((tso->flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } + + // Set up the top of the stack to apply the handler. + sp -= 4; + sp[0] = (W_)&stg_enter_info; + sp[1] = (W_)handler; + sp[2] = (W_)&stg_ap_pv_info; + sp[3] = (W_)exception; + + stack->sp = sp; RELAXED_STORE(&tso->what_next, ThreadRunGHC); goto done; } @@ -1079,6 +1071,15 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, }; default: + // see Note [Update async masking state on unwind] in Schedule.c + if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { + tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE); + } else if (*frame == (W_)&stg_maskAsyncExceptionszh_ret_info) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } else if (*frame == (W_)&stg_maskUninterruptiblezh_ret_info) { + tso->flags |= TSO_BLOCKEX; + tso->flags &= ~TSO_INTERRUPTIBLE; + } break; } @@ -1097,3 +1098,26 @@ done: return tso; } + +/* Note [Apply the handler directly in raiseAsync] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we encounter a `catch#` frame while unwinding the stack due to an +async exception, we need to set up the stack to resume execution by +invoking the exception handler. One natural way to do it would be to +simply place a `raise#` thunk on the top of the stack, ready to be +entered. This would effectively convert the asynchronous exception to +a synchronous one at a point where it’s known to be safe to do so. + +However, there is a danger to this strategy: if async exceptions are +currently unmasked, it becomes possible for a second async exception +to be delivered before we enter the application of `raise#`, which +would result in the first exception being lost. The easiest way to +prevent this race from happening is to have `raiseAsync` set up the +stack to apply the handler directly, effectively emulating the +behavior of `raise#`, as this allows exceptions to be preemptively +masked before returning. This means `raiseAsync` must also push a +frame to unmask async exceptions after the handler returns if +necessary, just as `raise#` does. + +This strategy results in some logical duplication, but it is correct, +and the duplicated logic is small enough to be acceptable. */ ===================================== rts/Schedule.c ===================================== @@ -3019,19 +3019,6 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) // thunks which are currently under evaluation. // - // OLD COMMENT (we don't have MIN_UPD_SIZE now): - // LDV profiling: stg_raise_info has THUNK as its closure - // type. Since a THUNK takes at least MIN_UPD_SIZE words in its - // payload, MIN_UPD_SIZE is more appropriate than 1. It seems that - // 1 does not cause any problem unless profiling is performed. - // However, when LDV profiling goes on, we need to linearly scan - // small object pool, where raise_closure is stored, so we should - // use MIN_UPD_SIZE. - // - // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate, - // sizeofW(StgClosure)+1); - // - // // Walk up the stack, looking for the catch frame. On the way, // we update any closures pointed to from update frames with the @@ -3094,12 +3081,52 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) } default: + // see Note [Update async masking state on unwind] + if (*p == (StgWord)&stg_unmaskAsyncExceptionszh_ret_info) { + tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE); + } else if (*p == (StgWord)&stg_maskAsyncExceptionszh_ret_info) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } else if (*p == (StgWord)&stg_maskUninterruptiblezh_ret_info) { + tso->flags |= TSO_BLOCKEX; + tso->flags &= ~TSO_INTERRUPTIBLE; + } p = next; continue; } } } +/* Note [Update async masking state on unwind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we raise an exception or capture a continuation, we unwind the +stack by searching for an enclosing `catch#` or `prompt#` frame. If we +unwind past frames intended to restore the async exception masking +state, we must take care to reproduce their intended effect in order +to ensure that async exceptions are properly unmasked or remasked. + +On paper, this seems as simple as updating `tso->flags` appropriately, +but in fact there is one additional wrinkle: when async exceptions are +*unmasked*, we must eagerly check for a pending async exception and +raise it if necessary. This is not terribly involved, but it’s not +trivial, either (see the definition of `stg_unmaskAsyncExceptionszh_ret`), +so we’d prefer to avoid duplicating that logic in several places. + +Fortunately, when we’re unwinding the stack due to a raised exception, +this detail is actually unimportant: `catch#` implicitly masks async +exceptions while running the handler as we explicitly *don’t* want the +thread to be interrupted before it has a chance to handle the +exception. However, when capturing a continuation, we don’t have this +luxury, so we take two different strategies: + +* When unwinding the stack due to a raised exception (synchonrous or + asynchronous), we just update `tso->flags` directly and take no + further action. + +* When unwinding the stack due to a continuation capture, we update + the masking state *indirectly* by pushing an appropriate frame onto + the stack before we return. This strategy is described at length + in Note [Continuations and async exception masking] in Continuation.c. */ + /* ----------------------------------------------------------------------------- findRetryFrameHelper ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -275,7 +275,6 @@ typedef struct { // Closure types: CATCH_FRAME typedef struct { StgHeader header; - StgWord exceptions_blocked; StgClosure *handler; } StgCatchFrame; ===================================== testsuite/tests/rts/continuations/T23513.hs ===================================== @@ -0,0 +1,36 @@ +-- This test checks that restoring a continuation that captures a CATCH frame +-- properly adjusts the async exception masking state. + +import Control.Exception +import Data.IORef + +import ContIO + +data E = E deriving (Show) +instance Exception E + +printMaskingState :: IO () +printMaskingState = print =<< getMaskingState + +main :: IO () +main = do + tag <- newPromptTag + ref <- newIORef Nothing + mask_ $ prompt tag $ + catch (control0 tag $ \k -> + writeIORef ref (Just k)) + (\E -> printMaskingState) + Just k <- readIORef ref + + let execute_test = do + k (printMaskingState *> throwIO E) + printMaskingState + + putStrLn "initially unmasked:" + execute_test + + putStrLn "\ninitially interruptibly masked:" + mask_ execute_test + + putStrLn "\ninitially uninterruptibly masked:" + uninterruptibleMask_ execute_test ===================================== testsuite/tests/rts/continuations/T23513.stdout ===================================== @@ -0,0 +1,14 @@ +initially unmasked: +Unmasked +MaskedInterruptible +Unmasked + +initially interruptibly masked: +MaskedInterruptible +MaskedInterruptible +MaskedInterruptible + +initially uninterruptibly masked: +MaskedUninterruptible +MaskedUninterruptible +MaskedUninterruptible ===================================== testsuite/tests/rts/continuations/all.T ===================================== @@ -7,3 +7,5 @@ test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', '']) test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', '']) test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"']) + +test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', '']) ===================================== utils/deriveConstants/Main.hs ===================================== @@ -482,7 +482,6 @@ wanteds os = concat ,closureField Both "StgUpdateFrame" "updatee" ,closureField C "StgCatchFrame" "handler" - ,closureField C "StgCatchFrame" "exceptions_blocked" ,closureSize C "StgPAP" ,closureField C "StgPAP" "n_args" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/540c96eb7af7cbca4673a51b9a19498247a2e6ed...821bddbb307829dbc72e145c88af1874cb80d373 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/540c96eb7af7cbca4673a51b9a19498247a2e6ed...821bddbb307829dbc72e145c88af1874cb80d373 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 Dec 14 10:02:06 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 05:02:06 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 6 commits: Second fix to #24083 Message-ID: <657ad29ee24f_2e72b31e4d3dfc209436@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 02e9904d by Simon Peyton Jones at 2023-12-14T15:31:50+05:30 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] (cherry picked from commit 2776920e642544477a38d0ed9205d4f0b48a782e) - - - - - a5e18815 by Alexis King at 2023-12-14T15:31:50+05:30 Don’t store the async exception masking state in CATCH frames (cherry picked from commit 8b61dfd6dfc78bfa6bb9449dac9a336e5d668b5e) (cherry picked from commit e538003c33251c5c843cac1e30b36f88bb859778) - - - - - 23969083 by Zubin Duggal at 2023-12-14T15:31:50+05:30 Bump array submodule to 0.5.6.0 - - - - - 1bc97aaf by Matthew Pickering at 2023-12-14T15:31:50+05:30 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 (cherry picked from commit 36b9a38cc45a26865c4e45f4949e519a5dede76d) - - - - - 35433a7b by Matthew Pickering at 2023-12-14T15:31:50+05:30 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 (cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a) - - - - - 0b051faf by Zubin Duggal at 2023-12-14T15:31:50+05:30 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 (cherry picked from commit 86f652dc9a649e59e643609c287a510a565f5408) - - - - - 18 changed files: - compiler/GHC/Tc/Gen/HsType.hs - hadrian/src/Settings/Warnings.hs - libraries/array - libraries/filepath - libraries/unix - linters/lint-submodule-refs/Main.hs - linters/linters-common/Linters/Common.hs - rts/Continuation.c - rts/Exception.cmm - rts/RaiseAsync.c - rts/Schedule.c - rts/include/rts/storage/Closures.h - + testsuite/tests/polykinds/T24083a.hs - testsuite/tests/polykinds/all.T - + testsuite/tests/rts/continuations/T23513.hs - + testsuite/tests/rts/continuations/T23513.stdout - testsuite/tests/rts/continuations/all.T - utils/deriveConstants/Main.hs Changes: ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -2535,13 +2535,14 @@ kcCheckDeclHeader_sig sig_kind name flav -- ^^^^^^^^^ -- We do it here because at this point the environment has been -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; ctx_k <- kc_res_ki + ; res_kind :: ContextKind <- kc_res_ki + -- Work out extra_arity, the number of extra invisible binders from -- the kind signature that should be part of the TyCon's arity. -- See Note [Arity inference in kcCheckDeclHeader_sig] ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs - invis_arity = case ctx_k of + invis_arity = case res_kind of AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders -- the signature into part of the arity of the TyCon OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the @@ -2555,12 +2556,9 @@ kcCheckDeclHeader_sig sig_kind name flav , ppr invis_arity, ppr invis_tcbs , ppr n_invis_tcbs ] - -- Unify res_ki (from the type declaration) with the residual kind from - -- the kind signature. Don't forget to apply the skolemising 'subst' first. - ; case ctx_k of - AnyKind -> return () -- No signature - _ -> do { res_ki <- newExpectedKind ctx_k - ; discardResult (unifyKind Nothing sig_res_kind' res_ki) } + -- Unify res_ki (from the type declaration) with + -- sig_res_kind', the residual kind from the kind signature. + ; checkExpectedResKind sig_res_kind' res_kind -- Add more binders for data/newtype, so the result kind has no arrows -- See Note [Datatype return kinds] @@ -2583,7 +2581,7 @@ kcCheckDeclHeader_sig sig_kind name flav ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs ; let implicit_prs = implicit_nms `zip` implicit_tvs ; checkForDuplicateScopedTyVars implicit_prs - ; checkForDisconnectedScopedTyVars all_tcbs implicit_prs + ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs -- Swizzle the Names so that the TyCon uses the user-declared implicit names -- E.g type T :: k -> Type @@ -2620,6 +2618,27 @@ kcCheckDeclHeader_sig sig_kind name flav ] ; return tc } +-- | Check the result kind annotation on a type constructor against +-- the corresponding section of the standalone kind signature. +-- Drops invisible binders that interfere with unification. +checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature + -> ContextKind -- ^ the result kind from the declaration header + -> TcM () +checkExpectedResKind _ AnyKind + = return () -- No signature in the declaration header +checkExpectedResKind sig_kind res_ki + = do { actual_res_ki <- newExpectedKind res_ki + + ; let -- Drop invisible binders from sig_kind until they match up + -- with res_ki. By analogy with checkExpectedKind. + n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki + n_sig_invis_bndrs = invisibleTyBndrCount sig_kind + n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs + + (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind + + ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki } + matchUpSigWithDecl :: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature -> TcKind -- The tail end of the kind signature @@ -2987,13 +3006,16 @@ expectedKindInCtxt _ = OpenKind * * ********************************************************************* -} -checkForDisconnectedScopedTyVars :: [TcTyConBinder] -> [(Name,TcTyVar)] -> TcM () +checkForDisconnectedScopedTyVars :: TyConFlavour -> [TcTyConBinder] + -> [(Name,TcTyVar)] -> TcM () -- See Note [Disconnected type variables] -- `scoped_prs` is the mapping gotten by unifying -- - the standalone kind signature for T, with -- - the header of the type/class declaration for T -checkForDisconnectedScopedTyVars sig_tcbs scoped_prs - = mapM_ report_disconnected (filterOut ok scoped_prs) +checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs + = when (needsEtaExpansion flav) $ + -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables] + mapM_ report_disconnected (filterOut ok scoped_prs) where sig_tvs = mkVarSet (binderVars sig_tcbs) ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs @@ -3070,6 +3092,25 @@ phantom synonym that just discards its argument. So our plan is this: See #24083 for dicussion of alternatives, none satisfactory. Also the fix is easy: just add an explicit `@kk` parameter to the declaration, to bind `kk` explicitly, rather than binding it implicitly via unification. + +(DTV1) We only want to make this check when there /are/ scoped type variables; and + that is determined by needsEtaExpansion. Examples: + + type C :: x -> y -> Constraint + class C a :: b -> Constraint where { ... } + -- The a,b scope over the "..." + + type D :: forall k. k -> Type + data family D :: kk -> Type + -- Nothing for `kk` to scope over! + + In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will + return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do + the check-for-disconnected-tyvars check we'll complain that `kk` is not bound + to one of `all_tcbs` (see #24083, comments about the `singletons` package). + + The scoped-tyvar stuff is needed precisely for data/class/newtype declarations, + where needsEtaExpansion is True. -} {- ********************************************************************* ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -30,7 +30,9 @@ ghcWarningsArgs = do , package binary ? pure [ "-Wno-deprecations" ] , package bytestring ? pure [ "-Wno-inline-rule-shadowing" ] , package compiler ? pure [ "-Wcpp-undef" ] - , package directory ? pure [ "-Wno-unused-imports" ] + , package directory ? pure [ "-Wno-unused-imports" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package ghc ? pure [ "-Wcpp-undef" , "-Wincomplete-uni-patterns" , "-Wincomplete-record-updates" @@ -53,5 +55,7 @@ ghcWarningsArgs = do , "-Wno-redundant-constraints" , "-Wno-orphans" ] , package unix ? pure [ "-Wno-deprecations" ] - , package win32 ? pure [ "-Wno-trustworthy-safe" ] + , package win32 ? pure [ "-Wno-trustworthy-safe" + , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 + ] , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] ===================================== libraries/array ===================================== @@ -1 +1 @@ -Subproject commit f487b8de85f2b271a3831c14ab6439b9bc9b8343 +Subproject commit 0daca5dfa33d6c522e9fb8e94a2b66a5ed658c20 ===================================== libraries/filepath ===================================== @@ -1 +1 @@ -Subproject commit 367f6bffc158ef1a9055fb876e23447636853aa4 +Subproject commit cdb5171f7774569b1a8028a78392cfa79f732b5c ===================================== libraries/unix ===================================== @@ -1 +1 @@ -Subproject commit 720debbf5b89366007bac473e8d7fd18e4114f1a +Subproject commit 0b3dbc9901fdf2d752c4ee7a7cee7b1ed20e76bd ===================================== linters/lint-submodule-refs/Main.hs ===================================== @@ -18,12 +18,12 @@ import System.Exit -- text import qualified Data.Text as T import qualified Data.Text.IO as T - ( putStrLn ) + ( putStrLn, putStr ) -- linters-common import Linters.Common ( GitType(..) - , gitBranchesContain, gitCatCommit, gitDiffTree, gitNormCid + , gitBranchesContain, gitIsTagged, gitCatCommit, gitDiffTree, gitNormCid ) -------------------------------------------------------------------------------- @@ -51,16 +51,18 @@ main = do exitWith (ExitFailure 1) bad <- fmap or $ forM smDeltas $ \(smPath,smCid) -> do - T.putStrLn $ " - " <> smPath <> " => " <> smCid + T.putStr $ " - " <> smPath <> " => " <> smCid let smAbsPath = dir ++ "/" ++ T.unpack smPath remoteBranches <- gitBranchesContain smAbsPath smCid + isTagged <- gitIsTagged smAbsPath smCid let (wip, nonWip) = partition ("wip/" `T.isPrefixOf`) originBranches originBranches = mapMaybe isOriginTracking remoteBranches isOriginTracking = T.stripPrefix "origin/" - let bad = null nonWip - when bad $ do + case (nonWip ++ isTagged) of + [] -> do + T.putStrLn " ... BAD" T.putStrLn $ " *FAIL* commit not found in submodule repo" T.putStrLn " or not reachable from persistent branches" T.putStrLn "" @@ -70,8 +72,15 @@ main = do commit <- gitNormCid smAbsPath ("origin/" <> branch) T.putStrLn $ " - " <> branch <> " -> " <> commit T.putStrLn "" - pure bad + return True + (b:bs) -> do + let more = case bs of + [] -> ")" + rest -> " and " <> T.pack (show (length rest)) <> " more)" + T.putStrLn $ "... OK (" <> b <> more + return False if bad then exitWith (ExitFailure 1) - else T.putStrLn " OK" + else T.putStrLn "OK" + ===================================== linters/linters-common/Linters/Common.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -105,6 +106,10 @@ gitBranchesContain d ref = do return $!! map (T.drop 2) tmp +gitIsTagged :: FilePath -> GitRef -> Sh [Text] +gitIsTagged d ref = + T.lines <$> runGit d "tag" ["--points-at", ref] + -- | returns @[(path, (url, key))]@ -- -- may throw exception ===================================== rts/Continuation.c ===================================== @@ -374,12 +374,12 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT // 1. We walk the stack to find the prompt frame to capture up to (if any). // // 2. If we successfully find a matching prompt, we proceed with the actual - // by allocating space for the continuation, performing the necessary - // copying, and unwinding the stack. + // capture by allocating space for the continuation, performing the + // necessary copying, and unwinding the stack. // // These variables are modified in Phase 1 to keep track of how far we had to // walk before finding the prompt frame. Afterwards, Phase 2 consults them to - // determine how to proceed with the actual capture. + // determine how to proceed. StgWord total_words = 0; bool in_first_chunk = true; ===================================== rts/Exception.cmm ===================================== @@ -393,16 +393,14 @@ stg_killMyself * kind of return to the activation record underneath us on the stack. */ -#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,exceptions_blocked,handler) \ +#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,handler) \ w_ info_ptr, \ PROF_HDR_FIELDS(w_,p1,p2) \ - w_ exceptions_blocked, \ p_ handler INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, - CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2, - exceptions_blocked,handler)) + CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,handler)) return (P_ ret) { return (ret); @@ -411,12 +409,7 @@ INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME, stg_catchzh ( P_ io, /* :: IO a */ P_ handler /* :: Exception -> IO a */ ) { - W_ exceptions_blocked; - STK_CHK_GEN(); - - exceptions_blocked = - TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE); TICK_CATCHF_PUSHED(); /* Apply R1 to the realworld token */ @@ -424,8 +417,7 @@ stg_catchzh ( P_ io, /* :: IO a */ TICK_SLOW_CALL_fast_v(); jump stg_ap_v_fast - (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, - exceptions_blocked, handler)) + (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, handler)) (io); } @@ -599,26 +591,28 @@ retry_pop_stack: frame = Sp; if (frame_type == CATCH_FRAME) { + // Note: if this branch is updated, there is a good chance that + // corresponding logic in `raiseAsync` must be updated to match! + // See Note [Apply the handler directly in raiseAsync] in RaiseAsync.c. + Sp = Sp + SIZEOF_StgCatchFrame; - if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) { + + W_ flags; + flags = TO_W_(StgTSO_flags(CurrentTSO)); + if ((flags & TSO_BLOCKEX) == 0) { Sp_adj(-1); Sp(0) = stg_unmaskAsyncExceptionszh_ret_info; } /* Ensure that async exceptions are masked when running the handler. - */ - StgTSO_flags(CurrentTSO) = %lobits32( - TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE); - - /* The interruptible state is inherited from the context of the + * + * The interruptible state is inherited from the context of the * catch frame, but note that TSO_INTERRUPTIBLE is only meaningful * if TSO_BLOCKEX is set. (we got this wrong earlier, and #4988 * was a symptom of the bug). */ - if ((StgCatchFrame_exceptions_blocked(frame) & - (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) == TSO_BLOCKEX) { - StgTSO_flags(CurrentTSO) = %lobits32( - TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE); + if ((flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) { + StgTSO_flags(CurrentTSO) = %lobits32(flags | TSO_BLOCKEX | TSO_INTERRUPTIBLE); } } else /* CATCH_STM_FRAME */ ===================================== rts/RaiseAsync.c ===================================== @@ -950,44 +950,36 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, case CATCH_FRAME: // If we find a CATCH_FRAME, and we've got an exception to raise, - // then build the THUNK raise(exception), and leave it on - // top of the CATCH_FRAME ready to enter. - // + // then set up the top of the stack to apply the handler; + // see Note [Apply the handler directly in raiseAsync]. { - StgCatchFrame *cf = (StgCatchFrame *)frame; - StgThunk *raise; - if (exception == NULL) break; - // we've got an exception to raise, so let's pass it to the - // handler in this frame. - // - raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1); - TICK_ALLOC_SE_THK(WDS(1),0); - SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs); - raise->payload[0] = exception; + StgClosure *handler = ((StgCatchFrame *)frame)->handler; - // throw away the stack from Sp up to the CATCH_FRAME. - // - sp = frame - 1; - - /* Ensure that async exceptions are blocked now, so we don't get - * a surprise exception before we get around to executing the - * handler. - */ - tso->flags |= TSO_BLOCKEX; - if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) { - tso->flags &= ~TSO_INTERRUPTIBLE; - } else { - tso->flags |= TSO_INTERRUPTIBLE; + // Throw away the stack from Sp up to and including the CATCH_FRAME. + sp = frame + stack_frame_sizeW((StgClosure *)frame); + + // Unmask async exceptions after running the handler, if necessary. + if ((tso->flags & TSO_BLOCKEX) == 0) { + sp--; + sp[0] = (W_)&stg_unmaskAsyncExceptionszh_ret_info; } - /* Put the newly-built THUNK on top of the stack, ready to execute - * when the thread restarts. - */ - sp[0] = (W_)raise; - sp[-1] = (W_)&stg_enter_info; - stack->sp = sp-1; + // Ensure that async exceptions are masked while running the handler; + // see Note [Apply the handler directly in raiseAsync]. + if ((tso->flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } + + // Set up the top of the stack to apply the handler. + sp -= 4; + sp[0] = (W_)&stg_enter_info; + sp[1] = (W_)handler; + sp[2] = (W_)&stg_ap_pv_info; + sp[3] = (W_)exception; + + stack->sp = sp; RELAXED_STORE(&tso->what_next, ThreadRunGHC); goto done; } @@ -1079,6 +1071,15 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, }; default: + // see Note [Update async masking state on unwind] in Schedule.c + if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { + tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE); + } else if (*frame == (W_)&stg_maskAsyncExceptionszh_ret_info) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } else if (*frame == (W_)&stg_maskUninterruptiblezh_ret_info) { + tso->flags |= TSO_BLOCKEX; + tso->flags &= ~TSO_INTERRUPTIBLE; + } break; } @@ -1097,3 +1098,26 @@ done: return tso; } + +/* Note [Apply the handler directly in raiseAsync] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we encounter a `catch#` frame while unwinding the stack due to an +async exception, we need to set up the stack to resume execution by +invoking the exception handler. One natural way to do it would be to +simply place a `raise#` thunk on the top of the stack, ready to be +entered. This would effectively convert the asynchronous exception to +a synchronous one at a point where it’s known to be safe to do so. + +However, there is a danger to this strategy: if async exceptions are +currently unmasked, it becomes possible for a second async exception +to be delivered before we enter the application of `raise#`, which +would result in the first exception being lost. The easiest way to +prevent this race from happening is to have `raiseAsync` set up the +stack to apply the handler directly, effectively emulating the +behavior of `raise#`, as this allows exceptions to be preemptively +masked before returning. This means `raiseAsync` must also push a +frame to unmask async exceptions after the handler returns if +necessary, just as `raise#` does. + +This strategy results in some logical duplication, but it is correct, +and the duplicated logic is small enough to be acceptable. */ ===================================== rts/Schedule.c ===================================== @@ -3019,19 +3019,6 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) // thunks which are currently under evaluation. // - // OLD COMMENT (we don't have MIN_UPD_SIZE now): - // LDV profiling: stg_raise_info has THUNK as its closure - // type. Since a THUNK takes at least MIN_UPD_SIZE words in its - // payload, MIN_UPD_SIZE is more appropriate than 1. It seems that - // 1 does not cause any problem unless profiling is performed. - // However, when LDV profiling goes on, we need to linearly scan - // small object pool, where raise_closure is stored, so we should - // use MIN_UPD_SIZE. - // - // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate, - // sizeofW(StgClosure)+1); - // - // // Walk up the stack, looking for the catch frame. On the way, // we update any closures pointed to from update frames with the @@ -3094,12 +3081,52 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) } default: + // see Note [Update async masking state on unwind] + if (*p == (StgWord)&stg_unmaskAsyncExceptionszh_ret_info) { + tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE); + } else if (*p == (StgWord)&stg_maskAsyncExceptionszh_ret_info) { + tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE; + } else if (*p == (StgWord)&stg_maskUninterruptiblezh_ret_info) { + tso->flags |= TSO_BLOCKEX; + tso->flags &= ~TSO_INTERRUPTIBLE; + } p = next; continue; } } } +/* Note [Update async masking state on unwind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we raise an exception or capture a continuation, we unwind the +stack by searching for an enclosing `catch#` or `prompt#` frame. If we +unwind past frames intended to restore the async exception masking +state, we must take care to reproduce their intended effect in order +to ensure that async exceptions are properly unmasked or remasked. + +On paper, this seems as simple as updating `tso->flags` appropriately, +but in fact there is one additional wrinkle: when async exceptions are +*unmasked*, we must eagerly check for a pending async exception and +raise it if necessary. This is not terribly involved, but it’s not +trivial, either (see the definition of `stg_unmaskAsyncExceptionszh_ret`), +so we’d prefer to avoid duplicating that logic in several places. + +Fortunately, when we’re unwinding the stack due to a raised exception, +this detail is actually unimportant: `catch#` implicitly masks async +exceptions while running the handler as we explicitly *don’t* want the +thread to be interrupted before it has a chance to handle the +exception. However, when capturing a continuation, we don’t have this +luxury, so we take two different strategies: + +* When unwinding the stack due to a raised exception (synchonrous or + asynchronous), we just update `tso->flags` directly and take no + further action. + +* When unwinding the stack due to a continuation capture, we update + the masking state *indirectly* by pushing an appropriate frame onto + the stack before we return. This strategy is described at length + in Note [Continuations and async exception masking] in Continuation.c. */ + /* ----------------------------------------------------------------------------- findRetryFrameHelper ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -275,7 +275,6 @@ typedef struct { // Closure types: CATCH_FRAME typedef struct { StgHeader header; - StgWord exceptions_blocked; StgClosure *handler; } StgCatchFrame; ===================================== testsuite/tests/polykinds/T24083a.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables, RankNTypes #-} + +module T24083a where + +type TyCon :: (k1 -> k2) -> unmatchable_fun +data family TyCon :: (k1 -> k2) -> unmatchable_fun ===================================== testsuite/tests/polykinds/all.T ===================================== @@ -243,3 +243,4 @@ test('T22379a', normal, compile, ['']) test('T22379b', normal, compile, ['']) test('T22743', normal, compile_fail, ['']) test('T24083', normal, compile_fail, ['']) +test('T24083a', normal, compile, ['']) ===================================== testsuite/tests/rts/continuations/T23513.hs ===================================== @@ -0,0 +1,36 @@ +-- This test checks that restoring a continuation that captures a CATCH frame +-- properly adjusts the async exception masking state. + +import Control.Exception +import Data.IORef + +import ContIO + +data E = E deriving (Show) +instance Exception E + +printMaskingState :: IO () +printMaskingState = print =<< getMaskingState + +main :: IO () +main = do + tag <- newPromptTag + ref <- newIORef Nothing + mask_ $ prompt tag $ + catch (control0 tag $ \k -> + writeIORef ref (Just k)) + (\E -> printMaskingState) + Just k <- readIORef ref + + let execute_test = do + k (printMaskingState *> throwIO E) + printMaskingState + + putStrLn "initially unmasked:" + execute_test + + putStrLn "\ninitially interruptibly masked:" + mask_ execute_test + + putStrLn "\ninitially uninterruptibly masked:" + uninterruptibleMask_ execute_test ===================================== testsuite/tests/rts/continuations/T23513.stdout ===================================== @@ -0,0 +1,14 @@ +initially unmasked: +Unmasked +MaskedInterruptible +Unmasked + +initially interruptibly masked: +MaskedInterruptible +MaskedInterruptible +MaskedInterruptible + +initially uninterruptibly masked: +MaskedUninterruptible +MaskedUninterruptible +MaskedUninterruptible ===================================== testsuite/tests/rts/continuations/all.T ===================================== @@ -7,3 +7,5 @@ test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', '']) test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', '']) test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"']) + +test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', '']) ===================================== utils/deriveConstants/Main.hs ===================================== @@ -482,7 +482,6 @@ wanteds os = concat ,closureField Both "StgUpdateFrame" "updatee" ,closureField C "StgCatchFrame" "handler" - ,closureField C "StgCatchFrame" "exceptions_blocked" ,closureSize C "StgPAP" ,closureField C "StgPAP" "n_args" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/821bddbb307829dbc72e145c88af1874cb80d373...0b051faf233406906e22c290f00a69277cdbb5ef -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/821bddbb307829dbc72e145c88af1874cb80d373...0b051faf233406906e22c290f00a69277cdbb5ef 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 Dec 14 10:24:56 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 05:24:56 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] Fix thunk update ordering Message-ID: <657ad7f8d9d73_2e72b31ee0cb302138bf@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 226b52f9 by Ben Gamari at 2023-12-14T15:54:44+05:30 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. (cherry picked from commit fa63b5902389aa929af5ec04b93b601fd456633f) (cherry picked from commit fcfb0850d1960b677a2f6b9bdf45d8ccef169aeb) - - - - - 17 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -701,10 +701,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) [node, CmmReg (CmmGlobal EagerBlackholeInfo)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal EagerBlackholeInfo)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1767,7 +1767,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1835,7 +1835,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1937,7 +1937,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2026,7 +2026,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2307,7 +2307,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -509,7 +509,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE; + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -517,7 +519,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -527,7 +532,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE; + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -661,6 +669,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE; jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -59,8 +59,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; @@ -76,9 +76,9 @@ INLINE_HEADER void updateWithIndirection (Capability *cap, /* See Note [Heap memory barriers] in SMP.h */ bdescr *bd = Bdescr((StgPtr)p1); if (bd->gen_no != 0) { - IF_NONMOVING_WRITE_BARRIER_ENABLED { - updateRemembSetPushThunk(cap, (StgThunk*)p1); - } + IF_NONMOVING_WRITE_BARRIER_ENABLED { + updateRemembSetPushThunk(cap, (StgThunk*)p1); + } recordMutableCap(p1, cap, bd->gen_no); TICK_UPD_OLD_IND(); } else { ===================================== rts/include/Cmm.h ===================================== @@ -309,7 +309,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -324,7 +324,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -785,7 +785,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/226b52f9626ca182256b083dabce925e30c35aa9 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/226b52f9626ca182256b083dabce925e30c35aa9 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 Dec 14 10:28:21 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Thu, 14 Dec 2023 05:28:21 -0500 Subject: [Git][ghc/ghc][wip/ipe-length] rts: drop unused postString function Message-ID: <657ad8c5b56ed_2e72b31f1ccb0821438@gitlab.mail> Zubin pushed to branch wip/ipe-length at Glasgow Haskell Compiler / GHC Commits: 6e03bfdf by Zubin Duggal at 2023-12-14T15:58:13+05:30 rts: drop unused postString function - - - - - 1 changed file: - rts/eventlog/EventLog.c Changes: ===================================== rts/eventlog/EventLog.c ===================================== @@ -198,16 +198,6 @@ static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len) eb->pos++; } -/* Post a null-terminated string to the event log. - * It is the caller's responsibility to ensure that there is - * enough room for strlen(buf)+1 bytes. - */ -static inline void postString(EventsBuf *eb, const char *buf) -{ - const StgWord len = buf ? strlen(buf) : 0; - postStringLen(eb, buf, len); -} - static inline StgWord64 time_ns(void) { return TimeToNS(stat_getElapsedTime()); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e03bfdfdb74de2a8b51d3008233392a6f0a9965 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e03bfdfdb74de2a8b51d3008233392a6f0a9965 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 Dec 14 10:33:39 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 05:33:39 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/sand-witch/lazy-skol-exp-pat-tys Message-ID: <657ada0382bd0_2e72b31f6301cc2149d0@gitlab.mail> Andrei Borzenkov pushed new branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sand-witch/lazy-skol-exp-pat-tys 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 Dec 14 10:34:27 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Thu, 14 Dec 2023 05:34:27 -0500 Subject: [Git][ghc/ghc][wip/hadrian-cross-stage2] 70 commits: metrics: Widen libdir and size_hello_obj acceptance window Message-ID: <657ada331942f_2e72b31f0348f421511a@gitlab.mail> Matthew Pickering pushed to branch wip/hadrian-cross-stage2 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 5786a0cd by Matthew Pickering at 2023-12-14T10:34:07+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. - - - - - 7bf4e670 by Matthew Pickering at 2023-12-14T10:34:07+00:00 fail when bindist configure fails - - - - - b367bd72 by Matthew Pickering at 2023-12-14T10:34:07+00:00 Correctly propagate build/host/target to bindist fix host/target bindist t - - - - - 2d6a69b0 by Matthew Pickering at 2023-12-14T10:34:07+00:00 ci: Test cross bindists - - - - - 539b95c6 by Matthew Pickering at 2023-12-14T10:34:07+00:00 CROSS_STAGE variable - - - - - 35238834 by Matthew Pickering at 2023-12-14T10:34:07+00:00 Use explicit syntax rather than pure - - - - - 461e91b3 by Matthew Pickering at 2023-12-14T10:34:07+00:00 ci: Javascript don't set CROSS_EMULATOR There is no CROSS_EMULATOR needed to run javascript binaries, so we don't set the CROSS_EMULATOR to some dummy value. - - - - - 089425a9 by Matthew Pickering at 2023-12-14T10:34:07+00:00 hadrian: Fill in more of the default.host toolchain file When you are building a cross compiler this file will be used to build stage1 and it's libraries, so we need enough information here to work accurately. There is still more work to be done (see for example, word size is still fixed). - - - - - d73674be by Matthew Pickering at 2023-12-14T10:34:07+00:00 hadrian: Build stage 2 cross compilers * Most of hadrian is abstracted over the stage in order to remove the assumption that the target of all stages is the same platform. This allows the RTS to be built for two different targets for example. * Abstracts the bindist creation logic to allow building either normal or cross bindists. Normal bindists use stage 1 libraries and a stage 2 compiler. Cross bindists use stage 2 libararies and a stage 2 compiler. ------------------------- Metric Decrease: T10421a T10858 T11195 T11276 T11374 T11822 T15630 T17096 T18478 T20261 Metric Increase: parsing001 ------------------------- - - - - - 263658ed by GHC GitLab CI at 2023-12-14T10:34:08+00:00 fix - - - - - 98375f8c by GHC GitLab CI at 2023-12-14T10:34:08+00:00 Build genapply per stage - - - - - 88942c14 by GHC GitLab CI at 2023-12-14T10:34:08+00:00 Correct GHC_PKG path - - - - - de001914 by GHC GitLab CI at 2023-12-14T10:34:08+00:00 Don't build genapply for javascript backend - - - - - 46d053bc by Matthew Pickering at 2023-12-14T10:34:08+00:00 hadrian: Make binary-dist-dir the default build target This allows us to have the logic in one place about which libraries/stages to build with cross compilers. - - - - - 73096b59 by Matthew Pickering at 2023-12-14T10:34:08+00:00 Fix exe path - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b45eff4aba09359d2e7ec49aaa09735d7724bff...73096b5919ff473191576cf30c0e6209df101dd6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3b45eff4aba09359d2e7ec49aaa09735d7724bff...73096b5919ff473191576cf30c0e6209df101dd6 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 Dec 14 10:36:14 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 05:36:14 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol-exp-pat-tys] Lazy skolemisation for @a-binders (17594) Message-ID: <657ada9e47778_2e72b31f1e38802158e7@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC Commits: 1218bfa7 by Andrei Borzenkov at 2023-12-14T14:35:56+04:00 Lazy skolemisation for @a-binders (17594) This patch is a preparation for @a-binders implementation. We have to accept SigmaType in matchExpectedFunTys function to implement them. To achieve that, I made skolemization more lazy. This leads to - Changing tcPolyCheck function. Now skolemisation is performed only in case ScopedTypeVariables extension enabled. - Changing tcExprSig function in the same way as tcPolyCheck - Changing tcPolyExpr function. Now it goes dipper into type if type actually is 1) HsPar 2) HsLam 3) HsLamCase In all other cases tcPolyExpr immediately skolemises a type as it was previously. These changes would allow lambdas to accept invisible type arguments in the most interesting contexts. - - - - - 17 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 - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs - testsuite/tests/indexed-types/should_compile/Simple14.stderr - testsuite/tests/rep-poly/RepPolyBackpack1.stderr - testsuite/tests/typecheck/should_fail/tcfail068.stderr - testsuite/tests/typecheck/should_fail/tcfail076.stderr Changes: ===================================== 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, tcMatchesFun, tc_matches_fun ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) @@ -625,7 +625,7 @@ tcPolyCheck prag_fn (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc }) - (L bind_loc (FunBind { fun_id = L nm_loc name + (L bind_loc (FunBind { fun_id = (L nm_loc name) , fun_matches = matches })) = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) @@ -633,7 +633,7 @@ tcPolyCheck prag_fn ; mult <- tcMultAnn (HsNoMultAnn noExtField) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems - tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> + tcSkolemiseScoped ctxt (idType poly_id) $ \imp_ty_vars rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah -- NB: tcSkolemiseScoped makes fresh type variables @@ -645,8 +645,8 @@ tcPolyCheck prag_fn -- See Note [Relevant bindings and the binder stack] setSrcSpanA bind_loc $ - tcMatchesFun (L nm_loc (idName mono_id)) mult matches - (mkCheckExpType rho_ty) + tc_matches_fun (L nm_loc (idName mono_id)) mult matches + (map mkInvisExpPatType imp_ty_vars) (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, - tcPolyExpr, tcExpr, + tcPolyLExpr, tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -176,6 +176,18 @@ tcInferRhoNC (L loc expr) ********************************************************************* -} tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr (HsPar x expr) res_ty + = do { expr' <- tcPolyLExprNC expr res_ty + ; return (HsPar x expr') } + +tcPolyExpr e@(HsLam x lam_variant matches) res_ty + = do { (wrap, matches') + <- tcMatchLambda herald match_ctxt matches res_ty + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + where + match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody } + herald = ExpectedFunTyLam lam_variant e + tcPolyExpr expr res_ty = do { traceTc "tcPolyExpr" (ppr res_ty) ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> @@ -793,7 +805,7 @@ tcSynArgE :: CtOrigin tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) <- tcTopSkolemise GenSigCtxt sigma_ty - (\ rho_ty -> go rho_ty syn_ty) + (\_ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -23,6 +23,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) +tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) + tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) @@ -42,4 +44,3 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxOpType -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) - ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -984,9 +984,17 @@ tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id - ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty -> - tcCheckMonoExprNC expr rho_ty + ; (wrap, expr') <- check_expr poly_ty ; return (mkLHsWrap wrap expr', poly_ty) } + where + check_expr poly_ty = do + stv <- xoptM LangExt.ScopedTypeVariables + if stv then + tcSkolemiseScoped ctxt poly_ty $ \_ rho_ty -> + tcCheckMonoExprNC expr rho_ty + else + do { res <- tcCheckPolyExprNC expr poly_ty + ; pure (idHsWrapper, res)} tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -17,6 +17,7 @@ -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match ( tcMatchesFun + , tc_matches_fun , tcGRHS , tcGRHSsPat , tcMatchesCase @@ -38,9 +39,9 @@ where import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC - , tcMonoExpr, tcMonoExprNC, tcExpr + , tcMonoExprNC, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC - , tcCheckPolyExpr ) + , tcCheckPolyExpr, tcPolyLExpr ) import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPatRn ) import GHC.Tc.Errors.Types @@ -81,6 +82,7 @@ import Control.Monad import Control.Arrow ( second ) import qualified Data.List.NonEmpty as NE import Data.Maybe (mapMaybe) +import GHC.Types.Var {- ************************************************************************ @@ -99,9 +101,17 @@ tcMatchesFun :: LocatedN Name -- MatchContext Id -> Mult -- The multiplicity of the binder -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcMatchesFun fun_name mult matches = tc_matches_fun fun_name mult matches [] + +tc_matches_fun :: LocatedN Name -- MatchContext Id + -> Mult -- The multiplicity of the binder + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tcMatchesFun fun_name mult matches exp_ty +tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty = 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 @@ -111,7 +121,8 @@ tcMatchesFun fun_name mult matches exp_ty traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; checkArgCounts what matches - ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + ; (wrapper, (mult_co_wrap, r)) <- + match_expected_fun_tys herald ctxt arity implicit_pat_tys exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that tcScalingUsage mult $ @@ -153,7 +164,7 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType + -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty = do { checkArgCounts (mc_what match_ctxt) match @@ -288,8 +299,13 @@ tcMatch ctxt pat_tys rhs_ty match -- We filter out type patterns because we have no use for them in HsToCore. -- Type variable bindings have already been converted to HsWrappers. filter_out_type_pats :: [LPat GhcTc] -> [LPat GhcTc] - filter_out_type_pats = filterByList (map is_fun_pat_ty pat_tys) + filter_out_type_pats = filterByList (map is_fun_pat_ty vis_pat_tys) where + vis_pat_tys = filterOut is_inv_pat_ty pat_tys + + is_inv_pat_ty (ExpForAllPatTy (Bndr _ Invisible{})) = True + is_inv_pat_ty _ = False + is_fun_pat_ty ExpFunPatTy{} = True is_fun_pat_ty ExpForAllPatTy{} = False @@ -361,10 +377,10 @@ tcDoStmts MonadComp (L l stmts) res_ty ; return (HsDo res_ty MonadComp (L l stmts')) } tcDoStmts ctxt at GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBody :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty + ; tcPolyLExpr body res_ty } {- ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -1,7 +1,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN ) @@ -17,3 +17,10 @@ tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) + +tc_matches_fun :: LocatedN Name + -> Mult + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpRhoType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -138,11 +138,32 @@ tcPats :: HsMatchContext GhcTc -- 3. Check the body -- 4. Check that no existentials escape -tcPats ctxt pats pat_tys thing_inside - = tc_tt_lpats pat_tys penv pats thing_inside +tcPats ctxt pats pat_tys thing_inside = do + pat_tys' <- filter_exp_tys pats pat_tys + tc_tt_lpats pat_tys' penv pats thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + filter_exp_tys :: [LPat GhcRn] -> [ExpPatType] -> TcM ([ExpPatType]) + + filter_exp_tys [] rest = pure (drop_invis_pats rest) + + -- visible patterns + filter_exp_tys pats@(L _ _ : _) (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = + filter_exp_tys pats (drop_invis_pats pat_tys) + filter_exp_tys (L _ _ : pats) (p : pat_tys) = do + (pat_tys') <- filter_exp_tys pats pat_tys + pure (p : pat_tys') + + -- invisible patterns + -- There are no at the moment + + filter_exp_tys (L _ _ :_) [] = + panic "filter_exp_tys: expected patterns more then expected pattern types" + + drop_invis_pats (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = drop_invis_pats pat_tys + drop_invis_pats pat_tys = pat_tys + tcInferPat :: FixedRuntimeRepContext -> HsMatchContext GhcTc -> LPat GhcRn @@ -406,7 +427,9 @@ tc_tt_pat pat_ty penv (ParPat x pat) thing_inside = do { (pat', res) <- tc_tt_lpat pat_ty penv pat thing_inside ; return (ParPat x pat', res) } tc_tt_pat (ExpFunPatTy pat_ty) penv pat thing_inside = tc_pat pat_ty penv pat thing_inside -tc_tt_pat (ExpForAllPatTy tv) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside +tc_tt_pat (ExpForAllPatTy (Bndr tv Required)) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside +tc_tt_pat (ExpForAllPatTy (Bndr _tv Invisible{})) _penv _pat _thing_inside + = panic "Patterns for invisible type binders aren't supported yet" tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc) tc_forall_pat _ (EmbTyPat _ tp, tv) thing_inside ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -831,7 +831,7 @@ tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper -- See Note [Handling SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap) - <- tcTopSkolemise ctxt spec_ty $ \ spec_tau -> + <- tcTopSkolemise ctxt spec_ty $ \_ spec_tau -> do { (inst_wrap, tau) <- topInstantiate orig poly_ty ; _ <- unifyType Nothing spec_tau tau -- Deliberately ignore the evidence ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Utils.Instantiate ( tcInstType, tcInstTypeBndrs, tcSkolemiseInvisibleBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyBindrVarsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -172,8 +172,8 @@ In general, topSkolemise :: SkolemInfo -> TcSigmaType -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Skolemisation] topSkolemise skolem_info ty @@ -183,13 +183,13 @@ topSkolemise skolem_info ty -- Why recursive? See Note [Skolemisation] go subst wrap tv_prs ev_vars ty - | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty + | (tvs, theta, inner_ty) <- tcSplitSigmaTyBindr ty , not (null tvs && null theta) - = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs + = do { (subst', tvs1) <- tcInstSkolTyBindrVarsX skolem_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' - (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) - (tv_prs ++ (map tyVarName tvs `zip` tvs1)) + (wrap <.> mkWpTyLams (binderVars tvs1) <.> mkWpEvLams ev_vars1) + (tv_prs ++ (map (tyVarName . binderVar) tvs `zip` tvs1)) (ev_vars ++ ev_vars1) inner_ty } @@ -514,6 +514,13 @@ tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False +tcInstSkolTyBindrVarsX :: SkolemInfo -> Subst -> [VarBndr TyCoVar vis] -> TcM (Subst, [VarBndr TyCoVar vis]) +tcInstSkolTyBindrVarsX skol_info subs bndrs = do + (subst', bndrs') <- tcInstSkolTyVarsX skol_info subs (binderVars bndrs) + pure (subst', zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Tc.Utils.TcMType ( -------------------------------- -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, newConcreteTyVarX, @@ -1022,6 +1022,13 @@ newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- Just like newMetaTyVars, but start with an existing substitution. newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst +newMetaTyVarBndrsX :: Subst -> [VarBndr TyVar vis] -> TcM (Subst, [VarBndr TcTyVar vis]) +newMetaTyVarBndrsX subst bndrs = do + (subst, bndrs') <- newMetaTyVarsX subst (binderVars bndrs) + pure (subst, zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -33,7 +33,7 @@ module GHC.Tc.Utils.TcType ( mkCheckExpType, checkingExpType_maybe, checkingExpType, - ExpPatType(..), + ExpPatType(..), mkInvisExpPatType, SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -76,7 +76,7 @@ module GHC.Tc.Utils.TcType ( tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcSplitIOType_maybe, + tcSplitSigmaTy, tcSplitSigmaTyBindr, tcSplitNestedSigmaTys, tcSplitIOType_maybe, --------------------------------- -- Predicates. @@ -462,7 +462,10 @@ checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) -- Expected type of a pattern in a lambda or a function left-hand side. data ExpPatType = ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B - | ExpForAllPatTy TcTyVar -- the binder (a::A) of forall (a::A) -> B + | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B + +mkInvisExpPatType :: InvisTyBinder -> ExpPatType +mkInvisExpPatType = ExpForAllPatTy . fmap Invisible instance Outputable ExpPatType where ppr (ExpFunPatTy t) = ppr t @@ -1435,6 +1438,11 @@ tcSplitSigmaTy ty = case tcSplitForAllInvisTyVars ty of (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) +tcSplitSigmaTyBindr :: Type -> ([TcInvisTVBinder], ThetaType, Type) +tcSplitSigmaTyBindr ty = case tcSplitForAllInvisTVBinders ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + -- | Split a sigma type into its parts, going underneath as many arrows -- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Tc.Utils.Unify ( matchExpectedListTy, matchExpectedTyConApp, matchExpectedAppTy, - matchExpectedFunTys, + matchExpectedFunTys, match_expected_fun_tys, matchExpectedFunKind, matchActualFunTySigma, matchActualFunTysRho, @@ -361,6 +361,15 @@ Example: with the type signature. -} +matchExpectedFunTys :: forall a. + ExpectedFunTyOrigin + -> UserTypeCtxt + -> Arity + -> ExpRhoType + -> ([ExpPatType] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +matchExpectedFunTys herald ctx arity = match_expected_fun_tys herald ctx arity [] + -- | Use this function to split off arguments types when you have an -- \"expected\" type. -- @@ -370,28 +379,29 @@ Example: -- to a list of argument types which all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] +match_expected_fun_tys :: forall a. + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> Arity - -> ExpRhoType -- Skolemised + -> [ExpPatType] -- implicit, previously skolemised pattern types + -> ExpRhoType -> ([ExpPatType] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (wrap, _) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald ctx arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty +match_expected_fun_tys herald ctx arity imp_pat_tys orig_ty thing_inside + = case orig_ty of -- go collects pat tys in reversed order + Check ty -> go (reverse imp_pat_tys) arity ty + _ -> defer (reverse imp_pat_tys) arity orig_ty where -- Skolemise any /invisible/ foralls /before/ the zero-arg case -- so that we guarantee to return a rho-type go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below - = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> - go acc_arg_tys n ty' + = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \imp_ty_pats ty' -> + go (acc_arg_tys ++ reverse (map mkInvisExpPatType imp_ty_pats)) n ty' ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ coreView, so @@ -416,7 +426,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { let arg_pos = 1 + length acc_arg_tys -- for error messages only + do { let arg_pos = 1 + length (filterOut is_invis_pat_ty acc_arg_tys) -- for error messages only ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; (wrap_res, result) <- go ((ExpFunPatTy $ Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty @@ -456,14 +466,14 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; let ty' = substTy subst' ty ; (ev_binds, (wrap_res, result)) <- checkConstraints (getSkolemInfo skol_info) [tv'] [] $ - go (ExpForAllPatTy tv' : acc_arg_tys) (n - 1) ty' + go (ExpForAllPatTy (mkForAllTyBinder Required tv') : acc_arg_tys) (n - 1) ty' ; let wrap_gen = mkWpVisTyLam tv' ty' <.> mkWpLet ev_binds ; return (wrap_gen <.> wrap_res, result) } ------------ defer :: [ExpPatType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) defer acc_arg_tys n fun_ty - = do { let last_acc_arg_pos = length acc_arg_tys + = do { let last_acc_arg_pos = length (filterOut is_invis_pat_ty acc_arg_tys) ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n] ; res_ty <- newInferExpType ; result <- thing_inside (reverse acc_arg_tys ++ map ExpFunPatTy more_arg_tys) res_ty @@ -479,14 +489,17 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside = mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) + is_invis_pat_ty (ExpForAllPatTy (Bndr _ Invisible{})) = True + is_invis_pat_ty _ = False + ------------ mk_ctxt :: [ExpPatType] -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) mk_ctxt arg_tys res_ty env = mkFunTysMsg env herald arg_tys' res_ty arity where - arg_tys' = map prepare_arg_ty (reverse arg_tys) + arg_tys' = map prepare_arg_ty (reverse (filterOut is_invis_pat_ty arg_tys)) prepare_arg_ty (ExpFunPatTy (Scaled u v)) = Anon (Scaled u (checkingExpType "matchExpectedFunTys" v)) visArgTypeLike - prepare_arg_ty (ExpForAllPatTy tv) = Named (Bndr tv Required) + prepare_arg_ty (ExpForAllPatTy tv) = Named tv -- this is safe b/c we're called from "go" mkFunTysMsg :: TidyEnv @@ -1046,7 +1059,7 @@ tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap) - <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> + <- tcTopSkolemise ctxt ty_expected $ \_ sk_rho -> do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual ; cow <- unify rho_a sk_rho ; return (mkWpCastN cow <.> wrap) } @@ -1069,7 +1082,7 @@ tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap) - <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho -> + <- tcDeeplySkolemise ctxt ty_expected $ \_ sk_rho -> -- See Note [Deep subsumption] tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho @@ -1372,7 +1385,7 @@ tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected tcDeeplySkolemise :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) + -> ([TcInvisTVBinder] -> TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- Just like tcTopSkolemise, but calls @@ -1380,29 +1393,16 @@ tcDeeplySkolemise -- See Note [Deep skolemisation] tcDeeplySkolemise ctxt expected_ty thing_inside | isTauTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty + = do { res <- thing_inside [] expected_ty ; return (idHsWrapper, res) } | otherwise - = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise; - -- but skol_info can't be built until we have tv_prs - rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs) - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op + = tcSkolemiseGeneral deeplySkolemise ctxt expected_ty (\tv_prs tc_ty -> + thing_inside (map snd tv_prs) tc_ty) deeplySkolemise :: SkolemInfo -> TcSigmaType -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Deep skolemisation] deeplySkolemise skol_info ty @@ -1411,14 +1411,14 @@ deeplySkolemise skol_info ty init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTyBndr_maybe ty = do { let arg_tys' = substScaledTys subst arg_tys ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs + ; (subst', tvs1) <- tcInstSkolTyBindrVarsX skol_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + ; let tv_prs1 = map (tyVarName . binderVar) tvs `zip` tvs1 + ; return ( mkWpEta ids1 (mkWpTyLams (binderVars tvs1) <.> mkWpEvLams ev_vars1 <.> wrap) , tv_prs1 ++ tvs_prs2 @@ -1450,21 +1450,31 @@ deeplyInstantiate orig ty = do { let ty' = substTy subst ty ; return (idHsWrapper, ty') } -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) + + +tcDeepSplit_maybe :: (Type -> ([a], ThetaType, Type)) -> TcSigmaType -> Maybe ([Scaled TcType], [a], ThetaType, TcSigmaType) -- Looks for a *non-trivial* quantified type, under zero or more function arrows -- By "non-trivial" we mean either tyvars or constraints are non-empty -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) +tcDeepSplit_maybe splitter = go where + go ty + | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- go res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- splitter ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) + | otherwise = Nothing - | otherwise = Nothing +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) +tcDeepSplitSigmaTy_maybe = tcDeepSplit_maybe tcSplitSigmaTy + +tcDeepSplitSigmaTyBndr_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType) +tcDeepSplitSigmaTyBndr_maybe = tcDeepSplit_maybe tcSplitSigmaTyBindr {- ********************************************************************* @@ -1504,9 +1514,30 @@ tcSkolemiseScoped is very similar, but differs in two ways: See Note [When to build an implication] below. -} +tcSkolemiseGeneral :: + (SkolemInfo -> TcType -> TcM (HsWrapper, [(Name, VarBndr TcTyVar vis)], [EvVar], TcType)) + -> UserTypeCtxt + -> TcType + -> ([(Name, VarBndr TcTyVar vis)] -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) result) + -> TcM (HsWrapper, result) +tcSkolemiseGeneral skolemise ctxt expected_ty thing_inside + = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty (map (fmap binderVar) tv_prs)) } + + ; let skol_tvs = map (binderVar . snd) tv_prs + ; (ev_binds, result) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + thing_inside tv_prs rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + tcTopSkolemise, tcSkolemiseScoped :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) + -> ([TcInvisTVBinder] -> TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- See Note [Skolemisation] for the differences between @@ -1516,37 +1547,17 @@ tcSkolemiseScoped ctxt expected_ty thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = deeplySkolemise | otherwise = topSkolemise - ; -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, res) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, res) } + ; tcSkolemiseGeneral skolemise ctxt expected_ty $ \tv_prs rho_ty -> + tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ + thing_inside (map snd tv_prs) rho_ty } tcTopSkolemise ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty + = do { res <- thing_inside [] expected_ty ; return (idHsWrapper, res) } | otherwise - = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op + = tcSkolemiseGeneral topSkolemise ctxt expected_ty $ \tv_prs rho_ty -> + thing_inside (map snd tv_prs) rho_ty -- | Variant of 'tcTopSkolemise' that takes an ExpType tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType @@ -1558,7 +1569,7 @@ tcSkolemiseExpType ctxt (Check ty) thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = tcDeeplySkolemise | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \rho_ty -> + ; skolemise ctxt ty $ \_ rho_ty -> thing_inside (mkCheckExpType rho_ty) } checkConstraints :: SkolemInfoAnon ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE DeriveFunctor #-} -- | -- #name_types# @@ -714,7 +715,7 @@ Currently there are nine different uses of 'VarBndr': data VarBndr var argf = Bndr var argf -- See Note [The VarBndr type and its uses] - deriving( Data ) + deriving( Data, Functor ) -- | Variable Binder -- ===================================== testsuite/tests/indexed-types/should_compile/Simple14.stderr ===================================== @@ -7,7 +7,7 @@ Simple14.hs:22:27: error: [GHC-83865] inside the constraints: Maybe m ~ Maybe n bound by a type expected by the context: (Maybe m ~ Maybe n) => EQ_ z0 z0 - at Simple14.hs:22:26-41 + at Simple14.hs:22:27-40 ‘n’ is a rigid type variable bound by the type signature for: foo :: forall m n. EQ_ (Maybe m) (Maybe n) ===================================== testsuite/tests/rep-poly/RepPolyBackpack1.stderr ===================================== @@ -1,6 +1,6 @@ [1 of 1] Processing number-unknown - [1 of 2] Compiling NumberUnknown[sig] ( number-unknown\NumberUnknown.hsig, nothing ) - [2 of 2] Compiling NumberStuff ( number-unknown\NumberStuff.hs, nothing ) + [1 of 2] Compiling NumberUnknown[sig] ( number-unknown/NumberUnknown.hsig, nothing ) + [2 of 2] Compiling NumberStuff ( number-unknown/NumberStuff.hs, nothing ) RepPolyBackpack1.bkp:17:5: error: [GHC-55287] The second pattern in the equation for ‘funcA’ ===================================== testsuite/tests/typecheck/should_fail/tcfail068.stderr ===================================== @@ -6,7 +6,7 @@ tcfail068.hs:14:9: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:(13,15)-(14,31) + at tcfail068.hs:14:9-30 ‘s’ is a rigid type variable bound by the type signature for: itgen :: forall a s. @@ -29,7 +29,7 @@ tcfail068.hs:19:21: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:(18,15)-(21,19) + at tcfail068.hs:(19,9)-(21,18) ‘s’ is a rigid type variable bound by the type signature for: itiap :: forall a s. @@ -53,7 +53,7 @@ tcfail068.hs:24:36: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:24:35-46 + at tcfail068.hs:24:36-45 ‘s’ is a rigid type variable bound by the type signature for: itrap :: forall a s. @@ -90,7 +90,7 @@ tcfail068.hs:36:46: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (c, IndTree s b) - at tcfail068.hs:36:45-63 + at tcfail068.hs:36:46-62 ‘s’ is a rigid type variable bound by the type signature for: itrapstate :: forall b a c s. ===================================== testsuite/tests/typecheck/should_fail/tcfail076.stderr ===================================== @@ -6,11 +6,11 @@ tcfail076.hs:19:82: error: [GHC-25897] ‘res1’ is a rigid type variable bound by a type expected by the context: forall res1. (b -> m res1) -> m res1 - at tcfail076.hs:19:71-88 + at tcfail076.hs:19:72-87 ‘res’ is a rigid type variable bound by a type expected by the context: forall res. (a -> m res) -> m res - at tcfail076.hs:19:35-96 + at tcfail076.hs:19:36-95 • In the expression: cont a In the first argument of ‘KContT’, namely ‘(\ cont' -> cont a)’ In the expression: KContT (\ cont' -> cont a) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1218bfa7560e41c7be95b866e67a36f385f2aca8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1218bfa7560e41c7be95b866e67a36f385f2aca8 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 Dec 14 10:38:47 2023 From: gitlab at gitlab.haskell.org (Matthew Pickering (@mpickering)) Date: Thu, 14 Dec 2023 05:38:47 -0500 Subject: [Git][ghc/ghc][wip/hadrian-cross-stage2] 14 commits: fail when bindist configure fails Message-ID: <657adb376c19c_2e72b31f60f1342160a9@gitlab.mail> Matthew Pickering pushed to branch wip/hadrian-cross-stage2 at Glasgow Haskell Compiler / GHC Commits: 9eec0e8d by Matthew Pickering at 2023-12-14T10:35:58+00:00 fail when bindist configure fails - - - - - c980f9be by Matthew Pickering at 2023-12-14T10:35:58+00:00 Correctly propagate build/host/target to bindist fix host/target bindist t - - - - - 5d304d5f by Matthew Pickering at 2023-12-14T10:35:58+00:00 ci: Test cross bindists - - - - - c3ec8dc1 by Matthew Pickering at 2023-12-14T10:35:58+00:00 CROSS_STAGE variable - - - - - 1088a7a9 by Matthew Pickering at 2023-12-14T10:35:58+00:00 Use explicit syntax rather than pure - - - - - 9a997c17 by Matthew Pickering at 2023-12-14T10:35:58+00:00 ci: Javascript don't set CROSS_EMULATOR There is no CROSS_EMULATOR needed to run javascript binaries, so we don't set the CROSS_EMULATOR to some dummy value. - - - - - 86b55939 by Matthew Pickering at 2023-12-14T10:35:58+00:00 hadrian: Fill in more of the default.host toolchain file When you are building a cross compiler this file will be used to build stage1 and it's libraries, so we need enough information here to work accurately. There is still more work to be done (see for example, word size is still fixed). - - - - - d7849d75 by Matthew Pickering at 2023-12-14T10:38:32+00:00 hadrian: Build stage 2 cross compilers * Most of hadrian is abstracted over the stage in order to remove the assumption that the target of all stages is the same platform. This allows the RTS to be built for two different targets for example. * Abstracts the bindist creation logic to allow building either normal or cross bindists. Normal bindists use stage 1 libraries and a stage 2 compiler. Cross bindists use stage 2 libararies and a stage 2 compiler. ------------------------- Metric Decrease: T10421a T10858 T11195 T11276 T11374 T11822 T15630 T17096 T18478 T20261 Metric Increase: parsing001 ------------------------- - - - - - 1a0aadb6 by GHC GitLab CI at 2023-12-14T10:38:33+00:00 fix - - - - - 1173f884 by GHC GitLab CI at 2023-12-14T10:38:33+00:00 Build genapply per stage - - - - - 0d967e3c by GHC GitLab CI at 2023-12-14T10:38:33+00:00 Correct GHC_PKG path - - - - - a3e3a86e by GHC GitLab CI at 2023-12-14T10:38:33+00:00 Don't build genapply for javascript backend - - - - - 9c1b30a4 by Matthew Pickering at 2023-12-14T10:38:33+00:00 hadrian: Make binary-dist-dir the default build target This allows us to have the logic in one place about which libraries/stages to build with cross compilers. - - - - - c4212be0 by Matthew Pickering at 2023-12-14T10:38:33+00:00 Fix exe path - - - - - 30 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/default.host.target.in - hadrian/src/Builder.hs - hadrian/src/Context.hs - hadrian/src/Expression.hs - hadrian/src/Flavour.hs - hadrian/src/Flavour/Type.hs - hadrian/src/Hadrian/Expression.hs - hadrian/src/Hadrian/Haskell/Hash.hs - hadrian/src/Hadrian/Oracles/TextFile.hs - hadrian/src/Oracles/Flag.hs - hadrian/src/Oracles/Flavour.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Oracles/TestSettings.hs - hadrian/src/Packages.hs - hadrian/src/Rules.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/CabalReinstall.hs - hadrian/src/Rules/Compile.hs - hadrian/src/Rules/Documentation.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Gmp.hs - hadrian/src/Rules/Libffi.hs - hadrian/src/Rules/Library.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73096b5919ff473191576cf30c0e6209df101dd6...c4212be0c107b8a7c6eed558959a2882c353f337 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/73096b5919ff473191576cf30c0e6209df101dd6...c4212be0c107b8a7c6eed558959a2882c353f337 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 Dec 14 12:39:05 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 07:39:05 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] 363 commits: hadrian: track python dependencies in doc rules Message-ID: <657af7698b7aa_2e72b32288a84824467f@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 9765ac7b by Zubin Duggal at 2023-09-05T00:37:45-04:00 hadrian: track python dependencies in doc rules - - - - - 1578215f by sheaf at 2023-09-05T00:38:26-04:00 Bump Haddock to fix #23616 This commit updates the Haddock submodule to include the fix to #23616. Fixes #23616 - - - - - 5a2fe35a by David Binder at 2023-09-05T00:39:07-04:00 Fix example in GHC user guide in SafeHaskell section The example given in the SafeHaskell section uses an implementation of Monad which no longer works. This MR removes the non-canonical return instance and adds the necessary instances of Functor and Applicative. - - - - - 291d81ae by Matthew Pickering at 2023-09-05T14:03:10-04:00 driver: Check transitive closure of haskell package dependencies when deciding whether to relink We were previously just checking whether direct package dependencies had been modified. This caused issues when compiling without optimisations as we wouldn't relink the direct dependency if one of its dependenices changed. Fixes #23724 - - - - - 35da0775 by Krzysztof Gogolewski at 2023-09-05T14:03:47-04:00 Re-export GHC.Utils.Panic.Plain from GHC.Utils.Panic Fixes #23930 - - - - - 3930d793 by Jaro Reinders at 2023-09-06T18:42:55-04:00 Make STG rewriter produce updatable closures - - - - - 0104221a by Krzysztof Gogolewski at 2023-09-06T18:43:32-04:00 configure: update message to use hadrian (#22616) - - - - - b34f8586 by Alan Zimmerman at 2023-09-07T10:58:38-04:00 EPA: Incorrect locations for UserTyVar with '@' In T13343.hs, the location for the @ is not within the span of the surrounding UserTyVar. type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v Widen it so it is captured. Closes #23887 - - - - - 8046f020 by Finley McIlwaine at 2023-09-07T10:59:15-04:00 Bump haddock submodule to fix #23920 Removes the fake export of `FUN` from Prelude. Fixes #23920. Bumps haddock submodule. - - - - - e0aa8c6e by Krzysztof Gogolewski at 2023-09-07T11:00:03-04:00 Fix wrong role in mkSelCo_maybe In the Lint failure in #23938, we start with a coercion Refl :: T a ~R T a, and call mkSelCo (SelTyCon 1 nominal) Refl. The function incorrectly returned Refl :: a ~R a. The returned role should be nominal, according to the SelCo rule: co : (T s1..sn) ~r0 (T t1..tn) r = tyConRole tc r0 i ---------------------------------- SelCo (SelTyCon i r) : si ~r ti In this test case, r is nominal while r0 is representational. - - - - - 1d92f2df by Gergő Érdi at 2023-09-08T04:04:30-04:00 If we have multiple defaulting plugins, then we should zonk in between them after any defaulting has taken place, to avoid a defaulting plugin seeing a metavariable that has already been filled. Fixes #23821. - - - - - eaee4d29 by Gergő Érdi at 2023-09-08T04:04:30-04:00 Improvements to the documentation of defaulting plugins Based on @simonpj's draft and comments in !11117 - - - - - ede3df27 by Alan Zimmerman at 2023-09-08T04:05:06-04:00 EPA: Incorrect span for LWarnDec GhcPs The code (from T23465.hs) {-# WARNInG in "x-c" e "d" #-} e = e gives an incorrect span for the LWarnDecl GhcPs Closes #23892 It also fixes the Test23465/Test23464 mixup - - - - - a0ccef7a by Krzysztof Gogolewski at 2023-09-08T04:05:42-04:00 Valid hole fits: don't suggest unsafeCoerce (#17940) - - - - - 88b942c4 by Oleg Grenrus at 2023-09-08T19:58:42-04:00 Add warning for badly staged types. Resolves #23829. The stage violation results in out-of-bound names in splices. Technically this is an error, but someone might rely on this!? Internal changes: - we now track stages for TyVars. - thLevel (RunSplice _) = 0, instead of panic, as reifyInstances does in fact rename its argument type, and it can contain variables. - - - - - 9861f787 by Ben Gamari at 2023-09-08T19:59:19-04:00 rts: Fix invalid symbol type I suspect this code is dead since we haven't observed this failing despite the obviously incorrect macro name. - - - - - 03ed6a9a by Ben Gamari at 2023-09-08T19:59:19-04:00 testsuite: Add simple test exercising C11 atomics in GHCi See #22012. - - - - - 1aa5733a by Ben Gamari at 2023-09-08T19:59:19-04:00 rts/RtsSymbols: Add AArch64 outline atomic operations Fixes #22012 by adding the symbols described in https://github.com/llvm/llvm-project/blob/main/llvm/docs/Atomics.rst#libcalls-atomic. Ultimately this would be better addressed by #22011, but this is a first step in the right direction and fixes the immediate symptom. Note that we dropped the `__arch64_cas16` operations as these provided by all platforms's compilers. Also, we don't link directly against the libgcc/compiler-rt definitions but rather provide our own wrappers to work around broken toolchains (e.g. https://bugs.gentoo.org/868018). Generated via https://gitlab.haskell.org/ghc/ghc/-/snippets/5733. - - - - - 8f7d3041 by Matthew Pickering at 2023-09-08T19:59:55-04:00 ci: Build debian12 and fedora38 bindists This adds builds for the latest releases for fedora and debian We build these bindists in nightly and release pipelines. - - - - - a1f0d55c by Felix Leitz at 2023-09-08T20:00:37-04:00 Fix documentation around extension implication for MultiParamTypeClasses/ConstrainedClassMethods. - - - - - 98166389 by Teo Camarasu at 2023-09-12T04:30:54-04:00 docs: move -xn flag beside --nonmoving-gc It makes sense to have these beside each other as they are aliases. - - - - - f367835c by Teo Camarasu at 2023-09-12T04:30:55-04:00 nonmoving: introduce a family of dense allocators Supplement the existing power 2 sized nonmoving allocators with a family of dense allocators up to a configurable threshold. This should reduce waste from rounding up block sizes while keeping the amount of allocator sizes manageable. This patch: - Adds a new configuration option `--nonmoving-dense-allocator-count` to control the amount of these new dense allocators. - Adds some constants to `NonmovingAllocator` in order to keep marking fast with the new allocators. Resolves #23340 - - - - - 2b07bf2e by Teo Camarasu at 2023-09-12T04:30:55-04:00 Add changelog entry for #23340 - - - - - f96fe681 by sheaf at 2023-09-12T04:31:44-04:00 Use printGhciException in run{Stmt, Decls} When evaluating statements in GHCi, we need to use printGhciException instead of the printException function that GHC provides in order to get the appropriate error messages that are customised for ghci use. - - - - - d09b932b by psilospore at 2023-09-12T04:31:44-04:00 T23686: Suggest how to enable Language Extension when in ghci Fixes #23686 - - - - - da30f0be by Matthew Craven at 2023-09-12T04:32:24-04:00 Unarise: Split Rubbish literals in function args Fixes #23914. Also adds a check to STG lint that these args are properly unary or nullary after unarisation - - - - - 261b6747 by Matthew Pickering at 2023-09-12T04:33:04-04:00 darwin: Bump MAXOSX_DEPLOYMENT_TARGET to 10.13 This bumps the minumum supported version to 10.13 (High Sierra) which is 6 years old at this point. Fixes #22938 - - - - - f418f919 by Mario Blažević at 2023-09-12T04:33:45-04:00 Fix TH pretty-printing of nested GADTs, issue #23937 This commit fixes `Language.Haskell.TH.Ppr.pprint` so that it correctly pretty-prints GADTs declarations contained within data family instances. Fixes #23937 - - - - - d7a64753 by John Ericson at 2023-09-12T04:34:20-04:00 Put hadrian non-bootstrap plans through `jq` This makes it possible to review changes with conventional diffing tools. This is picking up where ad8cfed4195b1bbfc15b841f010e75e71f63157d left off. - - - - - ff0a709a by Sylvain Henry at 2023-09-12T08:46:28-04:00 JS: fix some tests - Tests using Setup programs need to pass --with-hc-pkg - Several other fixes See https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend/bug_triage for the current status - - - - - fc86f0e7 by Krzysztof Gogolewski at 2023-09-12T08:47:04-04:00 Fix in-scope set assertion failure (#23918) Patch by Simon - - - - - 21a906c2 by Matthew Pickering at 2023-09-12T17:21:04+02:00 Add -Winconsistent-flags warning The warning fires when inconsistent command line flags are passed. For example: * -dynamic-too and -dynamic * -dynamic-too on windows * -O and --interactive * etc This is on by default and allows users to control whether the warning is displayed and whether it should be an error or not. Fixes #22572 - - - - - dfc4f426 by Krzysztof Gogolewski at 2023-09-12T20:31:35-04:00 Avoid serializing BCOs with the internal interpreter Refs #23919 - - - - - 9217950b by Finley McIlwaine at 2023-09-13T08:06:03-04:00 Fix numa auto configure - - - - - 98e7c1cf by Simon Peyton Jones at 2023-09-13T08:06:40-04:00 Add -fno-cse to T15426 and T18964 This -fno-cse change is to avoid these performance tests depending on flukey CSE stuff. Each contains several independent tests, and we don't want them to interact. See #23925. By killing CSE we expect a 400% increase in T15426, and 100% in T18964. Metric Increase: T15426 T18964 - - - - - 236a134e by Simon Peyton Jones at 2023-09-13T08:06:40-04:00 Tiny refactor canEtaReduceToArity was only called internally, and always with two arguments equal to zero. This patch just specialises the function, and renames it to cantEtaReduceFun. No change in behaviour. - - - - - 56b403c9 by Ben Gamari at 2023-09-13T19:21:36-04:00 spec-constr: Lift argument limit for SPEC-marked functions When the user adds a SPEC argument to a function, they are informing us that they expect the function to be specialised. However, previously this instruction could be preempted by the specialised-argument limit (sc_max_args). Fix this. This fixes #14003. - - - - - 6840012e by Simon Peyton Jones at 2023-09-13T19:22:13-04:00 Fix eta reduction Issue #23922 showed that GHC was bogusly eta-reducing a join point. We should never eta-reduce (\x -> j x) to j, if j is a join point. It is extremly difficult to trigger this bug. It took me 45 mins of trying to make a small tests case, here immortalised as T23922a. - - - - - 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. - - - - - 64112a49 by Andrei Borzenkov at 2023-12-14T16:38:47+04:00 Lazy skolemisation for @a-binders (17594) This patch is a preparation for @a-binders implementation. We have to accept SigmaType in matchExpectedFunTys function to implement them. To achieve that, I made skolemization more lazy. This leads to - Changing tcPolyCheck function. Now skolemisation is performed only in case ScopedTypeVariables extension enabled. - Changing tcExprSig function in the same way as tcPolyCheck - Changing tcPolyExpr function. Now it goes dipper into type if type actually is 1) HsPar 2) HsLam 3) HsLamCase In all other cases tcPolyExpr immediately skolemises a type as it was previously. These changes would allow lambdas to accept invisible type arguments in the most interesting contexts. - - - - - 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.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/PrimOps/Casts.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/Uniques.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/DebugBlock.hs - compiler/GHC/Cmm/Info.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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2329ee2a62fce6b0b9002109d355b1cdfa25f532...64112a492e1ea6e6282695991df1ad48edd90f8f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2329ee2a62fce6b0b9002109d355b1cdfa25f532...64112a492e1ea6e6282695991df1ad48edd90f8f 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 Dec 14 13:57:51 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 08:57:51 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol-exp-pat-tys] 2 commits: Lazy skolemisation for @a-binders (17594) Message-ID: <657b09df633e5_2e72b324753e28255285@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC Commits: be84c48d by Andrei Borzenkov at 2023-12-14T17:53:51+04:00 Lazy skolemisation for @a-binders (17594) This patch is a preparation for @a-binders implementation. We have to accept SigmaType in matchExpectedFunTys function to implement them. To achieve that, I made skolemization more lazy. This leads to - Changing tcPolyCheck function. Now it collects skolemised type variables and passes a list of them into tc_match_fun, so they could be used as [ExpPatType] with @-binsers. - Changing tcExprSig function, so now it only skolemises signature if there is `ScopedTypeVariables` extension enabled. - Changing tcPolyExpr function. Now it goes deeper into type if type actually is 1) HsPar 2) HsLam In all other cases tcPolyExpr immediately skolemises a type as it was previously. These changes would allow lambdas to accept invisible type arguments in the most interesting contexts. - - - - - d6b004cc by Andrei Borzenkov at 2023-12-14T17:57:29+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 17 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 - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs - testsuite/tests/indexed-types/should_compile/Simple14.stderr - testsuite/tests/rep-poly/RepPolyBackpack1.stderr - testsuite/tests/typecheck/should_fail/tcfail068.stderr - testsuite/tests/typecheck/should_fail/tcfail076.stderr Changes: ===================================== 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, tcMatchesFun, tc_matches_fun ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) @@ -633,7 +633,7 @@ tcPolyCheck prag_fn ; mult <- tcMultAnn (HsNoMultAnn noExtField) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems - tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> + tcSkolemiseScoped ctxt (idType poly_id) $ \imp_ty_vars rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah -- NB: tcSkolemiseScoped makes fresh type variables @@ -645,8 +645,8 @@ tcPolyCheck prag_fn -- See Note [Relevant bindings and the binder stack] setSrcSpanA bind_loc $ - tcMatchesFun (L nm_loc (idName mono_id)) mult matches - (mkCheckExpType rho_ty) + tc_matches_fun (L nm_loc (idName mono_id)) mult matches + (map mkInvisExpPatType imp_ty_vars) (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, - tcPolyExpr, tcExpr, + tcPolyLExpr, tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -176,6 +176,18 @@ tcInferRhoNC (L loc expr) ********************************************************************* -} tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr (HsPar x expr) res_ty + = do { expr' <- tcPolyLExprNC expr res_ty + ; return (HsPar x expr') } + +tcPolyExpr e@(HsLam x lam_variant matches) res_ty + = do { (wrap, matches') + <- tcMatchLambda herald match_ctxt matches res_ty + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + where + match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody } + herald = ExpectedFunTyLam lam_variant e + tcPolyExpr expr res_ty = do { traceTc "tcPolyExpr" (ppr res_ty) ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> @@ -793,7 +805,7 @@ tcSynArgE :: CtOrigin tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) <- tcTopSkolemise GenSigCtxt sigma_ty - (\ rho_ty -> go rho_ty syn_ty) + (\_ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -23,6 +23,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: -> TcRhoType -> TcM (LHsExpr GhcTc) +tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) + tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) @@ -42,4 +44,3 @@ tcSyntaxOpGen :: CtOrigin -> SyntaxOpType -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) - ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -984,9 +984,17 @@ tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id - ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty -> - tcCheckMonoExprNC expr rho_ty + ; (wrap, expr') <- check_expr poly_ty ; return (mkLHsWrap wrap expr', poly_ty) } + where + check_expr poly_ty = do + stv <- xoptM LangExt.ScopedTypeVariables + if stv then + tcSkolemiseScoped ctxt poly_ty $ \_ rho_ty -> + tcCheckMonoExprNC expr rho_ty + else + do { res <- tcCheckPolyExprNC expr poly_ty + ; pure (idHsWrapper, res)} tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -17,6 +17,7 @@ -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match ( tcMatchesFun + , tc_matches_fun , tcGRHS , tcGRHSsPat , tcMatchesCase @@ -38,9 +39,9 @@ where import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC - , tcMonoExpr, tcMonoExprNC, tcExpr + , tcMonoExprNC, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC - , tcCheckPolyExpr ) + , tcCheckPolyExpr, tcPolyLExpr ) import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPatRn ) import GHC.Tc.Errors.Types @@ -99,9 +100,17 @@ tcMatchesFun :: LocatedN Name -- MatchContext Id -> Mult -- The multiplicity of the binder -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcMatchesFun fun_name mult matches = tc_matches_fun fun_name mult matches [] + +tc_matches_fun :: LocatedN Name -- MatchContext Id + -> Mult -- The multiplicity of the binder + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tcMatchesFun fun_name mult matches exp_ty +tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty = 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 @@ -111,7 +120,8 @@ tcMatchesFun fun_name mult matches exp_ty traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) ; checkArgCounts what matches - ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + ; (wrapper, (mult_co_wrap, r)) <- + match_expected_fun_tys herald ctxt arity implicit_pat_tys exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that tcScalingUsage mult $ @@ -153,7 +163,7 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType + -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty = do { checkArgCounts (mc_what match_ctxt) match @@ -288,10 +298,9 @@ tcMatch ctxt pat_tys rhs_ty match -- We filter out type patterns because we have no use for them in HsToCore. -- Type variable bindings have already been converted to HsWrappers. filter_out_type_pats :: [LPat GhcTc] -> [LPat GhcTc] - filter_out_type_pats = filterByList (map is_fun_pat_ty pat_tys) + filter_out_type_pats = filterByList (map isExpFunPatTy vis_pat_tys) where - is_fun_pat_ty ExpFunPatTy{} = True - is_fun_pat_ty ExpForAllPatTy{} = False + vis_pat_tys = filterOut isExpForAllPatTyInvis pat_tys ------------- tcGRHSs :: AnnoBody body @@ -361,10 +370,10 @@ tcDoStmts MonadComp (L l stmts) res_ty ; return (HsDo res_ty MonadComp (L l stmts')) } tcDoStmts ctxt at GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt) -tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBody :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty + ; tcPolyLExpr body res_ty } {- ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -1,7 +1,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN ) @@ -17,3 +17,10 @@ tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) + +tc_matches_fun :: LocatedN Name + -> Mult + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpRhoType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -138,11 +138,32 @@ tcPats :: HsMatchContext GhcTc -- 3. Check the body -- 4. Check that no existentials escape -tcPats ctxt pats pat_tys thing_inside - = tc_tt_lpats pat_tys penv pats thing_inside +tcPats ctxt pats pat_tys thing_inside = do + pat_tys' <- filter_exp_tys pats pat_tys + tc_tt_lpats pat_tys' penv pats thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + filter_exp_tys :: [LPat GhcRn] -> [ExpPatType] -> TcM ([ExpPatType]) + + filter_exp_tys [] rest = pure (drop_invis_pats rest) + + -- visible patterns + filter_exp_tys pats@(L _ _ : _) (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = + filter_exp_tys pats (drop_invis_pats pat_tys) + filter_exp_tys (L _ _ : pats) (p : pat_tys) = do + (pat_tys') <- filter_exp_tys pats pat_tys + pure (p : pat_tys') + + -- invisible patterns + -- There are no at the moment + + filter_exp_tys (L _ _ :_) [] = + panic "filter_exp_tys: expected patterns more then expected pattern types" + + drop_invis_pats (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = drop_invis_pats pat_tys + drop_invis_pats pat_tys = pat_tys + tcInferPat :: FixedRuntimeRepContext -> HsMatchContext GhcTc -> LPat GhcRn @@ -406,7 +427,12 @@ tc_tt_pat pat_ty penv (ParPat x pat) thing_inside = do { (pat', res) <- tc_tt_lpat pat_ty penv pat thing_inside ; return (ParPat x pat', res) } tc_tt_pat (ExpFunPatTy pat_ty) penv pat thing_inside = tc_pat pat_ty penv pat thing_inside -tc_tt_pat (ExpForAllPatTy tv) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside +tc_tt_pat (ExpForAllPatTy (Bndr tv Required)) penv pat thing_inside = tc_forall_pat penv (pat, tv) thing_inside +tc_tt_pat (ExpForAllPatTy (Bndr _tv Invisible{})) _penv _pat _thing_inside + = panic "tc_tt_pat: invisible forall" + -- invisible foralls must have been filtered out + -- by drop_invis_pats in tcPats + tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc) tc_forall_pat _ (EmbTyPat _ tp, tv) thing_inside ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -831,7 +831,7 @@ tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper -- See Note [Handling SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap) - <- tcTopSkolemise ctxt spec_ty $ \ spec_tau -> + <- tcTopSkolemise ctxt spec_ty $ \_ spec_tau -> do { (inst_wrap, tau) <- topInstantiate orig poly_ty ; _ <- unifyType Nothing spec_tau tau -- Deliberately ignore the evidence ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -19,7 +19,7 @@ module GHC.Tc.Utils.Instantiate ( tcInstType, tcInstTypeBndrs, tcSkolemiseInvisibleBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarBndrsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -172,8 +172,8 @@ In general, topSkolemise :: SkolemInfo -> TcSigmaType -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Skolemisation] topSkolemise skolem_info ty @@ -183,13 +183,15 @@ topSkolemise skolem_info ty -- Why recursive? See Note [Skolemisation] go subst wrap tv_prs ev_vars ty - | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty + | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty + , let tvs = binderVars bndrs , not (null tvs && null theta) - = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) - (tv_prs ++ (map tyVarName tvs `zip` tvs1)) + (tv_prs ++ (map tyVarName tvs `zip` bndrs1)) (ev_vars ++ ev_vars1) inner_ty } @@ -514,6 +516,13 @@ tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False +tcInstSkolTyVarBndrsX :: SkolemInfo -> Subst -> [VarBndr TyCoVar vis] -> TcM (Subst, [VarBndr TyCoVar vis]) +tcInstSkolTyVarBndrsX skol_info subs bndrs = do + (subst', bndrs') <- tcInstSkolTyVarsX skol_info subs (binderVars bndrs) + pure (subst', zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -55,7 +55,7 @@ module GHC.Tc.Utils.TcMType ( -------------------------------- -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, newConcreteTyVarX, @@ -1022,6 +1022,13 @@ newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- Just like newMetaTyVars, but start with an existing substitution. newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst +newMetaTyVarBndrsX :: Subst -> [VarBndr TyVar vis] -> TcM (Subst, [VarBndr TcTyVar vis]) +newMetaTyVarBndrsX subst bndrs = do + (subst, bndrs') <- newMetaTyVarsX subst (binderVars bndrs) + pure (subst, zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -33,7 +33,7 @@ module GHC.Tc.Utils.TcType ( mkCheckExpType, checkingExpType_maybe, checkingExpType, - ExpPatType(..), + ExpPatType(..), mkInvisExpPatType, isExpForAllPatTyInvis, isExpFunPatTy, SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -76,7 +76,7 @@ module GHC.Tc.Utils.TcType ( tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcSplitIOType_maybe, + tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe, --------------------------------- -- Predicates. @@ -462,7 +462,18 @@ checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) -- Expected type of a pattern in a lambda or a function left-hand side. data ExpPatType = ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B - | ExpForAllPatTy TcTyVar -- the binder (a::A) of forall (a::A) -> B + | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B + +mkInvisExpPatType :: InvisTyBinder -> ExpPatType +mkInvisExpPatType = ExpForAllPatTy . fmap Invisible + +isExpForAllPatTyInvis :: ExpPatType -> Bool +isExpForAllPatTyInvis (ExpForAllPatTy (Bndr _ Invisible{})) = True +isExpForAllPatTyInvis _ = False + +isExpFunPatTy :: ExpPatType -> Bool +isExpFunPatTy ExpFunPatTy{} = True +isExpFunPatTy ExpForAllPatTy{} = False instance Outputable ExpPatType where ppr (ExpFunPatTy t) = ppr t @@ -1435,6 +1446,11 @@ tcSplitSigmaTy ty = case tcSplitForAllInvisTyVars ty of (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) +tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type) +tcSplitSigmaTyBndrs ty = case tcSplitForAllInvisTVBinders ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + -- | Split a sigma type into its parts, going underneath as many arrows -- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -32,7 +32,7 @@ module GHC.Tc.Utils.Unify ( matchExpectedListTy, matchExpectedTyConApp, matchExpectedAppTy, - matchExpectedFunTys, + matchExpectedFunTys, match_expected_fun_tys, matchExpectedFunKind, matchActualFunTySigma, matchActualFunTysRho, @@ -361,6 +361,15 @@ Example: with the type signature. -} +matchExpectedFunTys :: forall a. + ExpectedFunTyOrigin + -> UserTypeCtxt + -> Arity + -> ExpRhoType + -> ([ExpPatType] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +matchExpectedFunTys herald ctx arity = match_expected_fun_tys herald ctx arity [] + -- | Use this function to split off arguments types when you have an -- \"expected\" type. -- @@ -370,28 +379,29 @@ Example: -- to a list of argument types which all have a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -- See Note [Return arguments with a fixed RuntimeRep]. -matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] +match_expected_fun_tys :: forall a. + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> Arity - -> ExpRhoType -- Skolemised + -> [ExpPatType] -- implicit, previously skolemised pattern types + -> ExpRhoType -> ([ExpPatType] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (wrap, _) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald ctx arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty +match_expected_fun_tys herald ctx arity imp_pat_tys orig_ty thing_inside + = case orig_ty of -- go collects pat tys in reversed order + Check ty -> go (reverse imp_pat_tys) arity ty + _ -> defer (reverse imp_pat_tys) arity orig_ty where -- Skolemise any /invisible/ foralls /before/ the zero-arg case -- so that we guarantee to return a rho-type go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below - = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> - go acc_arg_tys n ty' + = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \imp_ty_pats ty' -> + go (acc_arg_tys ++ reverse (map mkInvisExpPatType imp_ty_pats)) n ty' ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ coreView, so @@ -416,7 +426,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) = assert (isVisibleFunArg af) $ - do { let arg_pos = 1 + length acc_arg_tys -- for error messages only + do { let arg_pos = 1 + length (filterOut isExpForAllPatTyInvis acc_arg_tys) -- for error messages only ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty ; (wrap_res, result) <- go ((ExpFunPatTy $ Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) (n-1) res_ty @@ -456,14 +466,14 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; let ty' = substTy subst' ty ; (ev_binds, (wrap_res, result)) <- checkConstraints (getSkolemInfo skol_info) [tv'] [] $ - go (ExpForAllPatTy tv' : acc_arg_tys) (n - 1) ty' + go (ExpForAllPatTy (mkForAllTyBinder Required tv') : acc_arg_tys) (n - 1) ty' ; let wrap_gen = mkWpVisTyLam tv' ty' <.> mkWpLet ev_binds ; return (wrap_gen <.> wrap_res, result) } ------------ defer :: [ExpPatType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) defer acc_arg_tys n fun_ty - = do { let last_acc_arg_pos = length acc_arg_tys + = do { let last_acc_arg_pos = length (filterOut isExpForAllPatTyInvis acc_arg_tys) ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n] ; res_ty <- newInferExpType ; result <- thing_inside (reverse acc_arg_tys ++ map ExpFunPatTy more_arg_tys) res_ty @@ -484,9 +494,9 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside mk_ctxt arg_tys res_ty env = mkFunTysMsg env herald arg_tys' res_ty arity where - arg_tys' = map prepare_arg_ty (reverse arg_tys) + arg_tys' = map prepare_arg_ty (reverse (filterOut isExpForAllPatTyInvis arg_tys)) prepare_arg_ty (ExpFunPatTy (Scaled u v)) = Anon (Scaled u (checkingExpType "matchExpectedFunTys" v)) visArgTypeLike - prepare_arg_ty (ExpForAllPatTy tv) = Named (Bndr tv Required) + prepare_arg_ty (ExpForAllPatTy tv) = Named tv -- this is safe b/c we're called from "go" mkFunTysMsg :: TidyEnv @@ -1046,7 +1056,7 @@ tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap) - <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> + <- tcTopSkolemise ctxt ty_expected $ \_ sk_rho -> do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual ; cow <- unify rho_a sk_rho ; return (mkWpCastN cow <.> wrap) } @@ -1069,7 +1079,7 @@ tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap) - <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho -> + <- tcDeeplySkolemise ctxt ty_expected $ \_ sk_rho -> -- See Note [Deep subsumption] tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho @@ -1372,7 +1382,7 @@ tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected tcDeeplySkolemise :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) + -> ([TcInvisTVBinder] -> TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- Just like tcTopSkolemise, but calls @@ -1380,29 +1390,16 @@ tcDeeplySkolemise -- See Note [Deep skolemisation] tcDeeplySkolemise ctxt expected_ty thing_inside | isTauTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty + = do { res <- thing_inside [] expected_ty ; return (idHsWrapper, res) } | otherwise - = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise; - -- but skol_info can't be built until we have tv_prs - rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs) - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op + = tcSkolemiseGeneral deeplySkolemise ctxt expected_ty (\tv_prs tc_ty -> + thing_inside (map snd tv_prs) tc_ty) deeplySkolemise :: SkolemInfo -> TcSigmaType -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Deep skolemisation] deeplySkolemise skol_info ty @@ -1411,13 +1408,15 @@ deeplySkolemise skol_info ty init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + | Just (arg_tys, bndrs, theta, ty') <- tcDeepSplitSigmaTyBndr_maybe ty = do { let arg_tys' = substScaledTys subst arg_tys + ; let tvs = binderVars bndrs ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs + ; (subst', bndrs1) <- tcInstSkolTyVarBndrsX skol_info subst bndrs + ; let tvs1 = binderVars bndrs1 ; ev_vars1 <- newEvVars (substTheta subst' theta) ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 + ; let tv_prs1 = map tyVarName tvs `zip` bndrs1 ; return ( mkWpEta ids1 (mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1 <.> wrap) @@ -1450,21 +1449,31 @@ deeplyInstantiate orig ty = do { let ty' = substTy subst ty ; return (idHsWrapper, ty') } -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) + + +tcDeepSplit_maybe :: (Type -> ([a], ThetaType, Type)) -> TcSigmaType -> Maybe ([Scaled TcType], [a], ThetaType, TcSigmaType) -- Looks for a *non-trivial* quantified type, under zero or more function arrows -- By "non-trivial" we mean either tyvars or constraints are non-empty -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) +tcDeepSplit_maybe splitter = go where + go ty + | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- go res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- splitter ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) +tcDeepSplitSigmaTy_maybe = tcDeepSplit_maybe tcSplitSigmaTy - | otherwise = Nothing +tcDeepSplitSigmaTyBndr_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType) +tcDeepSplitSigmaTyBndr_maybe = tcDeepSplit_maybe tcSplitSigmaTyBndrs {- ********************************************************************* @@ -1504,9 +1513,30 @@ tcSkolemiseScoped is very similar, but differs in two ways: See Note [When to build an implication] below. -} +tcSkolemiseGeneral :: + (SkolemInfo -> TcType -> TcM (HsWrapper, [(Name, VarBndr TcTyVar vis)], [EvVar], TcType)) + -> UserTypeCtxt + -> TcType + -> ([(Name, VarBndr TcTyVar vis)] -> TcType -> IOEnv (Env TcGblEnv TcLclEnv) result) + -> TcM (HsWrapper, result) +tcSkolemiseGeneral skolemise ctxt expected_ty thing_inside + = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty (map (fmap binderVar) tv_prs)) } + + ; let skol_tvs = map (binderVar . snd) tv_prs + ; (ev_binds, result) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + thing_inside tv_prs rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + tcTopSkolemise, tcSkolemiseScoped :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) + -> ([TcInvisTVBinder] -> TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- See Note [Skolemisation] for the differences between @@ -1516,37 +1546,17 @@ tcSkolemiseScoped ctxt expected_ty thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = deeplySkolemise | otherwise = topSkolemise - ; -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, res) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, res) } + ; tcSkolemiseGeneral skolemise ctxt expected_ty $ \tv_prs rho_ty -> + tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ + thing_inside (map snd tv_prs) rho_ty } tcTopSkolemise ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty + = do { res <- thing_inside [] expected_ty ; return (idHsWrapper, res) } | otherwise - = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op + = tcSkolemiseGeneral topSkolemise ctxt expected_ty $ \tv_prs rho_ty -> + thing_inside (map snd tv_prs) rho_ty -- | Variant of 'tcTopSkolemise' that takes an ExpType tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType @@ -1558,7 +1568,7 @@ tcSkolemiseExpType ctxt (Check ty) thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = tcDeeplySkolemise | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \rho_ty -> + ; skolemise ctxt ty $ \_ rho_ty -> thing_inside (mkCheckExpType rho_ty) } checkConstraints :: SkolemInfoAnon ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE DeriveFunctor #-} -- | -- #name_types# @@ -714,7 +715,7 @@ Currently there are nine different uses of 'VarBndr': data VarBndr var argf = Bndr var argf -- See Note [The VarBndr type and its uses] - deriving( Data ) + deriving( Data, Functor ) -- | Variable Binder -- ===================================== testsuite/tests/indexed-types/should_compile/Simple14.stderr ===================================== @@ -7,7 +7,7 @@ Simple14.hs:22:27: error: [GHC-83865] inside the constraints: Maybe m ~ Maybe n bound by a type expected by the context: (Maybe m ~ Maybe n) => EQ_ z0 z0 - at Simple14.hs:22:26-41 + at Simple14.hs:22:27-40 ‘n’ is a rigid type variable bound by the type signature for: foo :: forall m n. EQ_ (Maybe m) (Maybe n) ===================================== testsuite/tests/rep-poly/RepPolyBackpack1.stderr ===================================== @@ -1,6 +1,6 @@ [1 of 1] Processing number-unknown - [1 of 2] Compiling NumberUnknown[sig] ( number-unknown\NumberUnknown.hsig, nothing ) - [2 of 2] Compiling NumberStuff ( number-unknown\NumberStuff.hs, nothing ) + [1 of 2] Compiling NumberUnknown[sig] ( number-unknown/NumberUnknown.hsig, nothing ) + [2 of 2] Compiling NumberStuff ( number-unknown/NumberStuff.hs, nothing ) RepPolyBackpack1.bkp:17:5: error: [GHC-55287] The second pattern in the equation for ‘funcA’ ===================================== testsuite/tests/typecheck/should_fail/tcfail068.stderr ===================================== @@ -6,7 +6,7 @@ tcfail068.hs:14:9: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:(13,15)-(14,31) + at tcfail068.hs:14:9-30 ‘s’ is a rigid type variable bound by the type signature for: itgen :: forall a s. @@ -29,7 +29,7 @@ tcfail068.hs:19:21: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:(18,15)-(21,19) + at tcfail068.hs:(19,9)-(21,18) ‘s’ is a rigid type variable bound by the type signature for: itiap :: forall a s. @@ -53,7 +53,7 @@ tcfail068.hs:24:36: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (IndTree s a) - at tcfail068.hs:24:35-46 + at tcfail068.hs:24:36-45 ‘s’ is a rigid type variable bound by the type signature for: itrap :: forall a s. @@ -90,7 +90,7 @@ tcfail068.hs:36:46: error: [GHC-25897] ‘s1’ is a rigid type variable bound by a type expected by the context: forall s1. GHC.ST.ST s1 (c, IndTree s b) - at tcfail068.hs:36:45-63 + at tcfail068.hs:36:46-62 ‘s’ is a rigid type variable bound by the type signature for: itrapstate :: forall b a c s. ===================================== testsuite/tests/typecheck/should_fail/tcfail076.stderr ===================================== @@ -6,11 +6,11 @@ tcfail076.hs:19:82: error: [GHC-25897] ‘res1’ is a rigid type variable bound by a type expected by the context: forall res1. (b -> m res1) -> m res1 - at tcfail076.hs:19:71-88 + at tcfail076.hs:19:72-87 ‘res’ is a rigid type variable bound by a type expected by the context: forall res. (a -> m res) -> m res - at tcfail076.hs:19:35-96 + at tcfail076.hs:19:36-95 • In the expression: cont a In the first argument of ‘KContT’, namely ‘(\ cont' -> cont a)’ In the expression: KContT (\ cont' -> cont a) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1218bfa7560e41c7be95b866e67a36f385f2aca8...d6b004cc04ac7c2ecd5a8aeeca7028e8d9460782 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1218bfa7560e41c7be95b866e67a36f385f2aca8...d6b004cc04ac7c2ecd5a8aeeca7028e8d9460782 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 Dec 14 14:00:22 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 09:00:22 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] 3 commits: Lazy skolemisation for @a-binders (17594) Message-ID: <657b0a7673e7c_2e72b3244d075025754e@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: be84c48d by Andrei Borzenkov at 2023-12-14T17:53:51+04:00 Lazy skolemisation for @a-binders (17594) This patch is a preparation for @a-binders implementation. We have to accept SigmaType in matchExpectedFunTys function to implement them. To achieve that, I made skolemization more lazy. This leads to - Changing tcPolyCheck function. Now it collects skolemised type variables and passes a list of them into tc_match_fun, so they could be used as [ExpPatType] with @-binsers. - Changing tcExprSig function, so now it only skolemises signature if there is `ScopedTypeVariables` extension enabled. - Changing tcPolyExpr function. Now it goes deeper into type if type actually is 1) HsPar 2) HsLam In all other cases tcPolyExpr immediately skolemises a type as it was previously. These changes would allow lambdas to accept invisible type arguments in the most interesting contexts. - - - - - d6b004cc by Andrei Borzenkov at 2023-12-14T17:57:29+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 1b53bd98 by Andrei Borzenkov at 2023-12-14T18:00:07+04:00 Use flag instead of [ExpPatTy] - - - - - 30 changed files: - compiler/GHC/Core/TyCo/Rep.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/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs - libraries/base/tests/T23454.stderr - testsuite/tests/ado/T16135.stderr - testsuite/tests/ado/ado005.stderr - testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr - testsuite/tests/arrows/should_fail/T5380.stderr - testsuite/tests/backpack/should_fail/bkpfail24.stderr - testsuite/tests/backpack/should_fail/bkpfail44.stderr - testsuite/tests/dependent/should_fail/T14066d.stderr - testsuite/tests/dependent/should_fail/T14066e.stderr - testsuite/tests/gadt/T3169.stderr - testsuite/tests/gadt/T7558.stderr - testsuite/tests/gadt/rw.stderr - testsuite/tests/ghci/scripts/Defer02.stderr - testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr - testsuite/tests/indexed-types/should_compile/Simple14.stderr - testsuite/tests/indexed-types/should_compile/T15322a.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64112a492e1ea6e6282695991df1ad48edd90f8f...1b53bd98d10e731c11446e80bf6dce5f94bde860 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64112a492e1ea6e6282695991df1ad48edd90f8f...1b53bd98d10e731c11446e80bf6dce5f94bde860 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 Dec 14 14:01:59 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 09:01:59 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol] Use flag instead of [ExpPatTy] Message-ID: <657b0ad7a0d38_2e72b324cb275c258878@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol at Glasgow Haskell Compiler / GHC Commits: 5d64c820 by Andrei Borzenkov at 2023-12-14T18:01:48+04:00 Use flag instead of [ExpPatTy] - - - - - 30 changed files: - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - libraries/base/tests/T23454.stderr - testsuite/tests/ado/T16135.stderr - testsuite/tests/ado/ado005.stderr - testsuite/tests/arrows/should_fail/T20768_arrow_fail.stderr - testsuite/tests/arrows/should_fail/T5380.stderr - testsuite/tests/backpack/should_fail/bkpfail24.stderr - testsuite/tests/backpack/should_fail/bkpfail44.stderr - testsuite/tests/dependent/should_fail/T14066d.stderr - testsuite/tests/dependent/should_fail/T14066e.stderr - testsuite/tests/gadt/T3169.stderr - testsuite/tests/gadt/T7558.stderr - testsuite/tests/gadt/rw.stderr - testsuite/tests/ghci/scripts/Defer02.stderr - testsuite/tests/indexed-types/should_compile/PushedInAsGivens.stderr - testsuite/tests/indexed-types/should_compile/Simple14.stderr - testsuite/tests/indexed-types/should_compile/T15322a.stderr - testsuite/tests/indexed-types/should_compile/T3208b.stderr - testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr - testsuite/tests/indexed-types/should_fail/Overlap6.stderr - testsuite/tests/indexed-types/should_fail/SimpleFail5a.stderr - testsuite/tests/indexed-types/should_fail/T13674.stderr - testsuite/tests/indexed-types/should_fail/T14369.stderr - testsuite/tests/indexed-types/should_fail/T2627b.stderr - testsuite/tests/indexed-types/should_fail/T2664.stderr - testsuite/tests/indexed-types/should_fail/T3330a.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d64c8207ebe1559c258d91d3c673ffdfc38a775 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d64c8207ebe1559c258d91d3c673ffdfc38a775 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 Dec 14 14:32:47 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 09:32:47 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol-exp-pat-tys] fixup! Lazy skolemisation for @a-binders (17594) Message-ID: <657b120f891da_2e72b3255d4a242688b2@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC Commits: 4bbf51a4 by Andrei Borzenkov at 2023-12-14T18:32:39+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -138,32 +138,11 @@ tcPats :: HsMatchContext GhcTc -- 3. Check the body -- 4. Check that no existentials escape -tcPats ctxt pats pat_tys thing_inside = do - pat_tys' <- filter_exp_tys pats pat_tys - tc_tt_lpats pat_tys' penv pats thing_inside +tcPats ctxt pats pat_tys thing_inside = + tc_tt_lpats (filterOut isExpForAllPatTyInvis pat_tys) penv pats thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } - filter_exp_tys :: [LPat GhcRn] -> [ExpPatType] -> TcM ([ExpPatType]) - - filter_exp_tys [] rest = pure (drop_invis_pats rest) - - -- visible patterns - filter_exp_tys pats@(L _ _ : _) (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = - filter_exp_tys pats (drop_invis_pats pat_tys) - filter_exp_tys (L _ _ : pats) (p : pat_tys) = do - (pat_tys') <- filter_exp_tys pats pat_tys - pure (p : pat_tys') - - -- invisible patterns - -- There are no at the moment - - filter_exp_tys (L _ _ :_) [] = - panic "filter_exp_tys: expected patterns more then expected pattern types" - - drop_invis_pats (ExpForAllPatTy (Bndr _ Invisible{}) : pat_tys) = drop_invis_pats pat_tys - drop_invis_pats pat_tys = pat_tys - tcInferPat :: FixedRuntimeRepContext -> HsMatchContext GhcTc -> LPat GhcRn View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bbf51a4e91252939ba9fa99233317b1956f7d43 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4bbf51a4e91252939ba9fa99233317b1956f7d43 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 Dec 14 16:29:11 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Thu, 14 Dec 2023 11:29:11 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <657b2d57a317a_2e72b3282e264c2964f3@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 03103e27 by Sebastian Graf at 2023-12-14T17:28:53+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 19 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - + testsuite/tests/core-to-stg/T24124.hs - + testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,50 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline most applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2206,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,36 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp (Var token)] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + = do { (floats, thing) <- cpeBody env thing + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [lookupCorePrepEnv env token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1149,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1211,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1226,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1510,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1733,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1891,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2060,38 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) +{- +Eventually we want the following code, when #20749 is fixed. +Unfortunately, today it breaks T24124. + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. +-} + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + _is_lifted = not is_unlifted + _is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2109,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2142,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/core-to-stg/T24124.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Debug.Trace +import GHC.IO +import GHC.ST + +data StrictPair a b = !a :*: !b + +strictFun :: Int -> Int +{-# OPAQUE strictFun #-} +strictFun x = x*x*x + +opaqueId :: a -> a +{-# OPAQUE opaqueId #-} +{-# RULES + "opaqueId/noinline" opaqueId = noinline +#-} +-- work around noinline's special desugaring +opaqueId v = v + +evaluateST :: a -> ST s a +-- hide the fact that we are actually in IO because !11515 +-- causes seq# to look like it can throw precise exceptions +evaluateST x = ST (\s -> seq# x s) + +fun :: Int -> Int -> ST s Int +{-# OPAQUE fun #-} +fun = lazy $ \ !x y -> do + -- This should evaluate x before y. + _ <- evaluateST $ opaqueId (x :*: x) + _ <- evaluateST y + evaluateST $! strictFun x + +main :: IO () +main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13)) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -0,0 +1,2 @@ +x eval'd +y eval'd ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) +test('T24124', expect_broken(20749), compile_and_run, ['-O']) ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,23 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> let { sat [Occ=Once1] :: T15226b.StrictPair a b [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + T15226b.MkStrictPair! [sat conrep]; + } in Solo# [sat]; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03103e27edcb7ca16a2a4114387619010476de07 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03103e27edcb7ca16a2a4114387619010476de07 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 Dec 14 18:47:49 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 13:47:49 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol-exp-pat-tys] fixup! Lazy skolemisation for @a-binders (17594) Message-ID: <657b4dd5ded9d_2e72b32bdf6b703104d9@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC Commits: a612141e by Andrei Borzenkov at 2023-12-14T22:47:42+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 1 changed file: - compiler/GHC/Tc/Utils/Unify.hs Changes: ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -401,7 +401,7 @@ match_expected_fun_tys herald ctx arity imp_pat_tys orig_ty thing_inside | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \imp_ty_pats ty' -> - go (acc_arg_tys ++ reverse (map mkInvisExpPatType imp_ty_pats)) n ty' + go (reverse (map mkInvisExpPatType imp_ty_pats) ++ acc_arg_tys) n ty' ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ coreView, so View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a612141e7858ac7024c73b21c3466aad738f7081 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a612141e7858ac7024c73b21c3466aad738f7081 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 Dec 14 19:07:16 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Thu, 14 Dec 2023 14:07:16 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/check-@-binders] 353 commits: Add warning for badly staged types. Message-ID: <657b5263f4023_2e72b32c64dc88314949@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/check- at -binders at Glasgow Haskell Compiler / GHC Commits: 88b942c4 by Oleg Grenrus at 2023-09-08T19:58:42-04:00 Add warning for badly staged types. Resolves #23829. The stage violation results in out-of-bound names in splices. Technically this is an error, but someone might rely on this!? Internal changes: - we now track stages for TyVars. - thLevel (RunSplice _) = 0, instead of panic, as reifyInstances does in fact rename its argument type, and it can contain variables. - - - - - 9861f787 by Ben Gamari at 2023-09-08T19:59:19-04:00 rts: Fix invalid symbol type I suspect this code is dead since we haven't observed this failing despite the obviously incorrect macro name. - - - - - 03ed6a9a by Ben Gamari at 2023-09-08T19:59:19-04:00 testsuite: Add simple test exercising C11 atomics in GHCi See #22012. - - - - - 1aa5733a by Ben Gamari at 2023-09-08T19:59:19-04:00 rts/RtsSymbols: Add AArch64 outline atomic operations Fixes #22012 by adding the symbols described in https://github.com/llvm/llvm-project/blob/main/llvm/docs/Atomics.rst#libcalls-atomic. Ultimately this would be better addressed by #22011, but this is a first step in the right direction and fixes the immediate symptom. Note that we dropped the `__arch64_cas16` operations as these provided by all platforms's compilers. Also, we don't link directly against the libgcc/compiler-rt definitions but rather provide our own wrappers to work around broken toolchains (e.g. https://bugs.gentoo.org/868018). Generated via https://gitlab.haskell.org/ghc/ghc/-/snippets/5733. - - - - - 8f7d3041 by Matthew Pickering at 2023-09-08T19:59:55-04:00 ci: Build debian12 and fedora38 bindists This adds builds for the latest releases for fedora and debian We build these bindists in nightly and release pipelines. - - - - - a1f0d55c by Felix Leitz at 2023-09-08T20:00:37-04:00 Fix documentation around extension implication for MultiParamTypeClasses/ConstrainedClassMethods. - - - - - 98166389 by Teo Camarasu at 2023-09-12T04:30:54-04:00 docs: move -xn flag beside --nonmoving-gc It makes sense to have these beside each other as they are aliases. - - - - - f367835c by Teo Camarasu at 2023-09-12T04:30:55-04:00 nonmoving: introduce a family of dense allocators Supplement the existing power 2 sized nonmoving allocators with a family of dense allocators up to a configurable threshold. This should reduce waste from rounding up block sizes while keeping the amount of allocator sizes manageable. This patch: - Adds a new configuration option `--nonmoving-dense-allocator-count` to control the amount of these new dense allocators. - Adds some constants to `NonmovingAllocator` in order to keep marking fast with the new allocators. Resolves #23340 - - - - - 2b07bf2e by Teo Camarasu at 2023-09-12T04:30:55-04:00 Add changelog entry for #23340 - - - - - f96fe681 by sheaf at 2023-09-12T04:31:44-04:00 Use printGhciException in run{Stmt, Decls} When evaluating statements in GHCi, we need to use printGhciException instead of the printException function that GHC provides in order to get the appropriate error messages that are customised for ghci use. - - - - - d09b932b by psilospore at 2023-09-12T04:31:44-04:00 T23686: Suggest how to enable Language Extension when in ghci Fixes #23686 - - - - - da30f0be by Matthew Craven at 2023-09-12T04:32:24-04:00 Unarise: Split Rubbish literals in function args Fixes #23914. Also adds a check to STG lint that these args are properly unary or nullary after unarisation - - - - - 261b6747 by Matthew Pickering at 2023-09-12T04:33:04-04:00 darwin: Bump MAXOSX_DEPLOYMENT_TARGET to 10.13 This bumps the minumum supported version to 10.13 (High Sierra) which is 6 years old at this point. Fixes #22938 - - - - - f418f919 by Mario Blažević at 2023-09-12T04:33:45-04:00 Fix TH pretty-printing of nested GADTs, issue #23937 This commit fixes `Language.Haskell.TH.Ppr.pprint` so that it correctly pretty-prints GADTs declarations contained within data family instances. Fixes #23937 - - - - - d7a64753 by John Ericson at 2023-09-12T04:34:20-04:00 Put hadrian non-bootstrap plans through `jq` This makes it possible to review changes with conventional diffing tools. This is picking up where ad8cfed4195b1bbfc15b841f010e75e71f63157d left off. - - - - - ff0a709a by Sylvain Henry at 2023-09-12T08:46:28-04:00 JS: fix some tests - Tests using Setup programs need to pass --with-hc-pkg - Several other fixes See https://gitlab.haskell.org/ghc/ghc/-/wikis/javascript-backend/bug_triage for the current status - - - - - fc86f0e7 by Krzysztof Gogolewski at 2023-09-12T08:47:04-04:00 Fix in-scope set assertion failure (#23918) Patch by Simon - - - - - 21a906c2 by Matthew Pickering at 2023-09-12T17:21:04+02:00 Add -Winconsistent-flags warning The warning fires when inconsistent command line flags are passed. For example: * -dynamic-too and -dynamic * -dynamic-too on windows * -O and --interactive * etc This is on by default and allows users to control whether the warning is displayed and whether it should be an error or not. Fixes #22572 - - - - - dfc4f426 by Krzysztof Gogolewski at 2023-09-12T20:31:35-04:00 Avoid serializing BCOs with the internal interpreter Refs #23919 - - - - - 9217950b by Finley McIlwaine at 2023-09-13T08:06:03-04:00 Fix numa auto configure - - - - - 98e7c1cf by Simon Peyton Jones at 2023-09-13T08:06:40-04:00 Add -fno-cse to T15426 and T18964 This -fno-cse change is to avoid these performance tests depending on flukey CSE stuff. Each contains several independent tests, and we don't want them to interact. See #23925. By killing CSE we expect a 400% increase in T15426, and 100% in T18964. Metric Increase: T15426 T18964 - - - - - 236a134e by Simon Peyton Jones at 2023-09-13T08:06:40-04:00 Tiny refactor canEtaReduceToArity was only called internally, and always with two arguments equal to zero. This patch just specialises the function, and renames it to cantEtaReduceFun. No change in behaviour. - - - - - 56b403c9 by Ben Gamari at 2023-09-13T19:21:36-04:00 spec-constr: Lift argument limit for SPEC-marked functions When the user adds a SPEC argument to a function, they are informing us that they expect the function to be specialised. However, previously this instruction could be preempted by the specialised-argument limit (sc_max_args). Fix this. This fixes #14003. - - - - - 6840012e by Simon Peyton Jones at 2023-09-13T19:22:13-04:00 Fix eta reduction Issue #23922 showed that GHC was bogusly eta-reducing a join point. We should never eta-reduce (\x -> j x) to j, if j is a join point. It is extremly difficult to trigger this bug. It took me 45 mins of trying to make a small tests case, here immortalised as T23922a. - - - - - 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. - - - - - be84c48d by Andrei Borzenkov at 2023-12-14T17:53:51+04:00 Lazy skolemisation for @a-binders (17594) This patch is a preparation for @a-binders implementation. We have to accept SigmaType in matchExpectedFunTys function to implement them. To achieve that, I made skolemization more lazy. This leads to - Changing tcPolyCheck function. Now it collects skolemised type variables and passes a list of them into tc_match_fun, so they could be used as [ExpPatType] with @-binsers. - Changing tcExprSig function, so now it only skolemises signature if there is `ScopedTypeVariables` extension enabled. - Changing tcPolyExpr function. Now it goes deeper into type if type actually is 1) HsPar 2) HsLam In all other cases tcPolyExpr immediately skolemises a type as it was previously. These changes would allow lambdas to accept invisible type arguments in the most interesting contexts. - - - - - d6b004cc by Andrei Borzenkov at 2023-12-14T17:57:29+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 4bbf51a4 by Andrei Borzenkov at 2023-12-14T18:32:39+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - a612141e by Andrei Borzenkov at 2023-12-14T22:47:42+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - bb2b830b by Andrei Borzenkov at 2023-12-14T23:02:55+04:00 Parser, renamer, type checker for @a-binders (17594) As a part of GHC Proposal 448 were introduced invisible type patterns (@a-patterns) in functions and lambdas: id1 :: a -> a id1 @t x = x :: t id2 :: a -> a id2 = \ @t x -> x :: t Was introduced new data type ArgPat and now Match stores it instead of Pat. ArgPat has two constructors: VisPat for common patterns and InvisPat for @-patterns. Parsing is implemented in production argpat. Was introduced ArgPatBuilder to help post process new patterns. Renaming of ArgPat is implemented in rnArgPats function. Type checking is a bit tricky due to eager scolemisation. It's implemented in new functions tcTopSkolemiseExpPatTys, tcSkolemiseScopedExpPatTys, and tcArgPats. For more information about hack with collecting `ExpPatType`s see Note [Type-checking invisible type patterns: check mode] Type-checking is currently limited by check mode and -XNoDeepSubsumption. Examples of new code: id1 :: forall a. a -> a id1 @t x = x :: t id2 :: a -> a id2 @t x = x :: t id3 :: a -> a id3 = \ @t x -> x id_RankN :: (forall a. a -> a) -> a -> a id_RankN @t f = f @t id4 = id_RankN \ @t x -> x :: t id_list :: [forall a. a -> a] id_list = [\ @t x -> x] Metric Increase: LargeRecord RecordUpdPerf - - - - - 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/Names/TH.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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f94f787ed33beb3f2c623249ce5a108be5f1306...bb2b830b634daf0bb75bd52b3fd646b64bf761a4 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f94f787ed33beb3f2c623249ce5a108be5f1306...bb2b830b634daf0bb75bd52b3fd646b64bf761a4 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 Dec 14 20:55:03 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Thu, 14 Dec 2023 15:55:03 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Last EpAnn in extension points Message-ID: <657b6ba7caa36_2e72b32ed8f2b0322746@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: a8d1288a by Alan Zimmerman at 2023-12-14T20:27:48+00:00 EPA: Last EpAnn in extension points Leaving a few that are too tricky, maybe some other time. - - - - - 3 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Parser.y - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -427,7 +427,7 @@ instance NoAnn AnnsIf where -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) +type instance XSCC (GhcPass _) = (AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel ===================================== compiler/GHC/Parser.y ===================================== @@ -2752,7 +2752,7 @@ exp_prag(e) :: { ECP } : prag_e e -- See Note [Pragmas and operator fixity] {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - return $ (sLLa $1 $> $ HsPragE noExtField (unLoc $1) $2) } + amsA' $ (sLL $1 $> $ HsPragE noExtField (unLoc $1) $2) } exp10 :: { ECP } -- See Note [%shift: exp10 -> '-' fexp] @@ -2814,16 +2814,16 @@ may sound unnecessary, but it's actually needed to support a common idiom: -} prag_e :: { Located (HsPragE GhcPs) } : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 - ; acs (\cs -> (sLL $1 $> + ; return (sLL $1 $> (HsPragSCC - ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs), + (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2], (getSCC_PRAGs $1)) - (StringLiteral (getSTRINGs $2) scc Nothing))))} } - | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $> + (StringLiteral (getSTRINGs $2) scc Nothing)))} } + | '{-# SCC' VARID '#-}' { sLL $1 $> (HsPragSCC - ((EpAnn (glEE $1 $>) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs), + (AnnPragma (mo $1) (mc $3) [mj AnnVal $2], (getSCC_PRAGs $1)) - (StringLiteral NoSourceText (getVARID $2) Nothing)))) } + (StringLiteral NoSourceText (getVARID $2) Nothing)) } fexp :: { ECP } : fexp aexp { ECP $ ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3241,11 +3241,11 @@ instance ExactPrint (HsPragE GhcPs) where setAnnotationAnchor a _ _ _ = a exact (HsPragSCC (an,st) sl) = do - an0 <- markAnnOpenP an st "{-# SCC" + an0 <- markAnnOpenP' an st "{-# SCC" let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) - an1 <- markEpAnnLMS an0 lapr_rest AnnVal (Just txt) -- optional - an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional - an3 <- markAnnCloseP an2 + an1 <- markEpAnnLMS'' an0 lapr_rest AnnVal (Just txt) -- optional + an2 <- markEpAnnLMS'' an1 lapr_rest AnnValStr (Just txt) -- optional + an3 <- markAnnCloseP' an2 return (HsPragSCC (an3,st) sl) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8d1288a56e59fa7f8b7c137449b9f965996cf14 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8d1288a56e59fa7f8b7c137449b9f965996cf14 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 Dec 14 23:23:46 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Thu, 14 Dec 2023 18:23:46 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] 53 commits: Only exit ghci in -e mode when :add command fails Message-ID: <657b8e82b67a9_2e72b3327f72cc334690@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 111f7637 by Alan Zimmerman at 2023-12-14T21:42:57+00:00 EPA: HsOverLabel: move annotation info to xrec-stuff - - - - - 2344ca96 by Alan Zimmerman at 2023-12-14T22:06:21+00:00 EPA: Moving non-token annotations out of HsIPVar, HsOverLit, HsLit - - - - - 753077f0 by Alan Zimmerman at 2023-12-14T22:06:28+00:00 EPA: Moving EpAnn out of extension points A lot done, more to do still. I am making ' versions of helper functions, when the work is complete the originals will disappear and the ' will go. Dump.hs needed to be able to properly blank out `[AddEpAnn]`, they used to be wrapped in an `EpAnn` which was easy to blank. - - - - - 694e88dd by Alan Zimmerman at 2023-12-14T22:06:34+00:00 EPA: Remove last EpAnn from HsExpr extension points - - - - - 38fc5c7a by Alan Zimmerman at 2023-12-14T22:32:58+00:00 EPA: remove EpAnn from HsParTy and HsFunTy - - - - - 278f1618 by Alan Zimmerman at 2023-12-14T22:33:02+00:00 EPA: Remove EpAnn from most HsType extension points Just a few tricky ones left, coming next - - - - - 374463c2 by Alan Zimmerman at 2023-12-14T22:39:19+00:00 EPA: Remove EpAnn from last extension points HsType Also replace `EpAnn NoEpAnns` with `EpAnnCO` - - - - - 439279a2 by Alan Zimmerman at 2023-12-14T22:39:27+00:00 EPA: Starting to remove EpAnn from Decl extension points - - - - - 237d8e4f by Alan Zimmerman at 2023-12-14T22:39:32+00:00 EPA: Removing more EpAnn from Decls extension points - - - - - 7c476a7e by Alan Zimmerman at 2023-12-14T22:57:36+00:00 EPA: Remove EpAnn from SigD extension points - - - - - f7b87bfa by Alan Zimmerman at 2023-12-14T23:05:04+00:00 EPA: Remove last EpAnn from extension points - - - - - 63be3271 by Alan Zimmerman at 2023-12-14T23:05:07+00:00 EPA: Last EpAnn in extension points Leaving a few that are too tricky, maybe some other time. - - - - - 30 changed files: - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d1288a56e59fa7f8b7c137449b9f965996cf14...63be32711753a83d4d8df82f003088bd84966b85 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8d1288a56e59fa7f8b7c137449b9f965996cf14...63be32711753a83d4d8df82f003088bd84966b85 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 Dec 15 12:14:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 15 Dec 2023 07:14:27 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 26 commits: Fix unusable units and module reexport interaction (#21097) Message-ID: <657c43239947b_e7a733e56f349919a@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 1ae57288 by Sylvain Henry at 2023-12-15T17:17:29+05:30 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. (cherry picked from commit cee81370cd6ef256f66035e3116878d4cb82e28b) - - - - - cc1097f3 by Zubin Duggal at 2023-12-15T17:17:29+05:30 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 (cherry picked from commit fa148f6ed43f915f2ae40302dda1b8bae39512af) - - - - - cd61dd26 by Zubin Duggal at 2023-12-15T17:17:29+05:30 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 (cherry picked from commit a62d4cb25b805dd7e12476db97a667fd542ea006) - - - - - 33b3ff8a by Zubin Duggal at 2023-12-15T17:17:29+05:30 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 (cherry picked from commit 244d3315352376eb7b946843fb0c512412842d7d) - - - - - 27fec1c3 by Zubin Duggal at 2023-12-15T17:17:29+05:30 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 (cherry picked from commit 306cb4e3e02e466f6c5a57c1a65fd2a5d13b3f89) - - - - - 74fa25f0 by Zubin Duggal at 2023-12-15T17:17:30+05:30 compiler: Force IfGlobalRdrEnv in NFData instance. (cherry picked from commit 77a3b580f561e62f5ac7ebf6588199575aafd3b4) - - - - - 2e4b7832 by Pierre Le Marre at 2023-12-15T17:17:30+05:30 Update to Unicode 15.1.0 See: https://www.unicode.org/versions/Unicode15.1.0/ (cherry picked from commit 778c84b61679a8bb9dd83e2c41156abc0f39abd3) - - - - - b8eac3cf by Simon Peyton Jones at 2023-12-15T17:17:30+05:30 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 (cherry picked from commit 6dbab1808bfbe484b3fb396aab1d105314f918d8) - - - - - 110efc98 by Simon Peyton Jones at 2023-12-15T17:17:30+05:30 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] (cherry picked from commit 2776920e642544477a38d0ed9205d4f0b48a782e) - - - - - 01b8a66b by Alexis King at 2023-12-15T17:17:30+05:30 Don’t store the async exception masking state in CATCH frames (cherry picked from commit 8b61dfd6dfc78bfa6bb9449dac9a336e5d668b5e) (cherry picked from commit e538003c33251c5c843cac1e30b36f88bb859778) - - - - - cfbf9aa9 by Zubin Duggal at 2023-12-15T17:17:30+05:30 Bump array submodule to 0.5.6.0 - - - - - bd31c2bb by Matthew Pickering at 2023-12-15T17:17:30+05:30 libraries: Bump filepath to 1.4.200.1 and unix to 2.8.4.0 Updates filepath submodule Updates unix submodule Fixes #24240 (cherry picked from commit 36b9a38cc45a26865c4e45f4949e519a5dede76d) - - - - - 207f897a by Matthew Pickering at 2023-12-15T17:17:30+05:30 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 (cherry picked from commit 91ff0971df64b04938d011fe1562320c5d90849a) - - - - - 1fa23f43 by Zubin Duggal at 2023-12-15T17:17:30+05:30 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 (cherry picked from commit 86f652dc9a649e59e643609c287a510a565f5408) - - - - - 76bc5445 by Ben Gamari at 2023-12-15T17:17:30+05:30 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. (cherry picked from commit fa63b5902389aa929af5ec04b93b601fd456633f) (cherry picked from commit fcfb0850d1960b677a2f6b9bdf45d8ccef169aeb) - - - - - 2de05890 by Bryan Richter at 2023-12-15T17:17:30+05:30 Work around perf note fetch failure Addresses #24055. (cherry picked from commit 63afb701a1638d7bd32c34fb24a9fd3ff897b634) - - - - - 592e41e2 by Zubin Duggal at 2023-12-15T17:17:30+05:30 Bump haddock submodule to 2.29.2 - - - - - 30d1b643 by Moritz Angermann at 2023-12-15T17:17:40+05:30 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. (cherry picked from commit a3ee3b99e6889fd68da75c6ea7a14d101f71da56) - - - - - 5a77075c by Matthew Craven at 2023-12-15T17:39:36+05:30 Make 'wWarningFlagsDeps' include every WarningFlag Fixes #24071. (cherry picked from commit a2c0fff61afdb14b5f2624374aa5767e7b238ff4) - - - - - 31bc8575 by Ben Gamari at 2023-12-15T17:40:16+05:30 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. (cherry picked from commit d0b17576148d336b67c7d65bcf742f83001413cb) - - - - - a62134f2 by Ben Gamari at 2023-12-15T17:40:25+05:30 rts/eventlog: Honor result of ensureRoomForVariableEvent is Previously we would keep plugging along, even if isn't enough room for the event. (cherry picked from commit a10f9b9bc510051a5b47d31238aad1174f7a1966) - - - - - 472582dc by Ben Gamari at 2023-12-15T17:40:34+05:30 rts/eventlog: Avoid truncating event sizes Previously ensureRoomForVariableEvent would truncate the desired size to 16-bits, resulting in #24197. Fixes #24197. (cherry picked from commit 0e0f41c0e3d9c67fc669e975060e88bccdc7d823) - - - - - 65699dd6 by Ben Gamari at 2023-12-15T17:41:37+05:30 rts/EventLog: Place eliminate duplicate strlens Previously many of the `post*` implementations would first compute the length of the event's strings in order to determine the event length. Later we would then end up computing the length yet again in `postString`. Now we instead pass the string length to `postStringLen`, avoiding the repeated work. (cherry picked from commit c350df3ce0e5c207b90eb3e74e04c77826c56283) - - - - - 39236678 by Ben Gamari at 2023-12-15T17:41:45+05:30 rts/eventlog: Place upper bound on IPE string field lengths The strings in IPE events may be of unbounded length. Limit the lengths of these fields to 64k characters to ensure that we don't exceed the maximum event length. (cherry picked from commit 9340d9987abe2ebf7f66659ffc48a822586f6edd) - - - - - bc444199 by Zubin Duggal at 2023-12-15T17:41:51+05:30 rts: drop unused postString function (cherry picked from commit 6e03bfdfdb74de2a8b51d3008233392a6f0a9965) - - - - - 8b9486ae by Zubin Duggal at 2023-12-15T17:43:37+05:30 Bump base to 4.18.2.0 and add changelog - - - - - 30 changed files: - .gitlab/test-metrics.sh - compiler/GHC/Data/Bag.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Unit/State.hs - configure.ac - distrib/configure.ac.in - hadrian/src/Settings/Warnings.hs - libraries/array - libraries/base/GHC/Unicode/Internal/Char/DerivedCoreProperties.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/GeneralCategory.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleLowerCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleTitleCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleUpperCaseMapping.hs - libraries/base/GHC/Unicode/Internal/Version.hs - libraries/base/base.cabal The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/226b52f9626ca182256b083dabce925e30c35aa9...8b9486ae2ccbb105df0a8883b55b27a56f3b23c2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/226b52f9626ca182256b083dabce925e30c35aa9...8b9486ae2ccbb105df0a8883b55b27a56f3b23c2 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 Dec 15 13:04:33 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 15 Dec 2023 08:04:33 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <657c4ee17ae57_e7a7351b4f541011b2@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: f9b00f5c by Sebastian Graf at 2023-12-15T14:03:25+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 20 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - + testsuite/tests/core-to-stg/T24124.hs - + testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,59 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline saturated applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Mainly for reasons of backwards compatibility, we recognise `seq#` during + Demand Analysis as not throwing a precise exception by the mechanism + implementing Note [Precise exceptions and strictness analysis]. + More concretely, `case seq# x s of (# s', x' #) -> y` is detected strict in + `y`, which is how all PrimOps except `raiseIO#` are treated. + +(SEQ4) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: return False for seq#. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2215,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Opt.WorkWrap.Utils +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -602,16 +603,21 @@ exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException envs e | not (forcesRealWorld envs (exprType e)) = False -- 1. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just op <- isPrimOpId_maybe f , op /= RaiseIOOp = False -- 2. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just fcall <- isFCallId_maybe f , not (isSafeForeignCall fcall) = False -- 3. in the Note + | Var f <- fn + , f `hasKey` seqHashIdKey + = False -- 3. in the Note | otherwise = True -- _. in the Note + where + (fn, _) = collectArgs e -- | Recognises types that are -- * @State# RealWorld@ @@ -799,14 +805,16 @@ For an expression @f a1 ... an :: ty@ we determine that (Why not simply unboxed pairs as above? This is motivated by T13380{d,e}.) 2. False If f is a PrimOp, and it is *not* raiseIO# - 3. False If f is an unsafe FFI call ('PlayRisky') + 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic]. + 4. False If f is an unsafe FFI call ('PlayRisky') _. True Otherwise "give up". It is sound to return False in those cases, because 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions from pure code. 2. raiseIO# is the only primop that may throw a precise exception. - 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + 3. `seq# = \(!a) s -> (# a, s #)`, so it does not throw a precise exception. + 4. Unsafe FFI calls may not interact with the RTS (to throw, for example). See haddock on GHC.Types.ForeignCall.PlayRisky. We *need* to return False in those cases, because @@ -814,7 +822,8 @@ We *need* to return False in those cases, because 2. We would lose strictness for primops like getMaskingState#, which introduces a substantial regression in GHC.IO.Handle.Internals.wantReadableHandle. - 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + 3. `seq#` used to be a PrimOp and we want to stay backwards compatible. + 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData, where an intermittent FFI call to c_MD5Init would otherwise lose strictness on the arguments len and buf, leading to regressions in T9203 (2%) and i386's haddock.base (5%). Tested by T13380f. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,38 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp token] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + -- and turning token into a CpeArg as needed + = do { (floats1, thing) <- cpeBody env thing + ; (floats2, token) <- cpeArg env topDmd token + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1151,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1213,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1228,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1512,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1735,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1893,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2062,38 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) +{- +Eventually we want the following code, when #20749 is fixed. +Unfortunately, today it breaks T24124. + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. +-} + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + _is_lifted = not is_unlifted + _is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2111,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2144,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/core-to-stg/T24124.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Debug.Trace +import GHC.IO +import GHC.ST + +data StrictPair a b = !a :*: !b + +strictFun :: Int -> Int +{-# OPAQUE strictFun #-} +strictFun x = x*x*x + +opaqueId :: a -> a +{-# OPAQUE opaqueId #-} +{-# RULES + "opaqueId/noinline" opaqueId = noinline +#-} +-- work around noinline's special desugaring +opaqueId v = v + +evaluateST :: a -> ST s a +-- hide the fact that we are actually in IO because !11515 +-- causes seq# to look like it can throw precise exceptions +evaluateST x = ST (\s -> seq# x s) + +fun :: Int -> Int -> ST s Int +{-# OPAQUE fun #-} +fun = lazy $ \ !x y -> do + -- This should evaluate x before y. + _ <- evaluateST $ opaqueId (x :*: x) + _ <- evaluateST y + evaluateST $! strictFun x + +main :: IO () +main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13)) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -0,0 +1,2 @@ +x eval'd +y eval'd ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) +test('T24124', compile_and_run, compile_and_run, ['-O']) ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,21 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> - let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> + case T15226b.MkStrictPair [sat conrep] of sat { + __DEFAULT -> Solo# [sat]; + }; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9b00f5c07c1b4b01aa4c3e9d2fe163815493807 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9b00f5c07c1b4b01aa4c3e9d2fe163815493807 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 Dec 15 13:34:26 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 15 Dec 2023 08:34:26 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] Bump base to 4.18.2.0 and add changelog Message-ID: <657c55e2ccc41_e7a735f153c41045f2@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 5ac485d2 by Zubin Duggal at 2023-12-15T19:04:19+05:30 Bump base to 4.18.2.0 and add changelog - - - - - 4 changed files: - libraries/base/base.cabal - libraries/base/changelog.md - testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout - testsuite/tests/cabal/t18567/T18567.stderr Changes: ===================================== libraries/base/base.cabal ===================================== @@ -1,6 +1,6 @@ cabal-version: 3.0 name: base -version: 4.18.1.0 +version: 4.18.2.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause ===================================== libraries/base/changelog.md ===================================== @@ -2,6 +2,7 @@ ## 4.18.2.0 *January 2024* * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/). + * Improve String & IsString documentation. ## 4.18.1.0 *September 2023* ===================================== testsuite/tests/backpack/cabal/bkpcabal02/bkpcabal02.stdout ===================================== @@ -4,4 +4,4 @@ for bkpcabal01-0.1.0.0.. Preprocessing library 'q' for bkpcabal01-0.1.0.0.. Building library 'q' instantiated with H = for bkpcabal01-0.1.0.0.. -[2 of 2] Instantiating bkpcabal01-0.1.0.0-FiLzfB7mZtYE6BMmiNv9fa-p +[2 of 2] Instantiating bkpcabal01-0.1.0.0-1lAnZxoLksL6JibM6aQmCb-p ===================================== testsuite/tests/cabal/t18567/T18567.stderr ===================================== @@ -2,4 +2,4 @@ : warning: [GHC-42258] [-Wunused-packages] The following packages were specified via -package or -package-id flags, but were not needed for compilation: - - internal-lib-0.1.0.0 (exposed by flag -package-id internal-lib-0.1.0.0-F26eZWnX3iaKM2e47PKLTm-sublib-unused) + - internal-lib-0.1.0.0 (exposed by flag -package-id internal-lib-0.1.0.0-7jHSByQDwC214cJdttV4hN-sublib-unused) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ac485d289569dbed00a764f07ed388d41a563f6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ac485d289569dbed00a764f07ed388d41a563f6 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 Dec 15 13:50:42 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 15 Dec 2023 08:50:42 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <657c59b2397e3_e7a73645cf5811225d@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 91476c60 by Sebastian Graf at 2023-12-15T14:49:59+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 20 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - + testsuite/tests/core-to-stg/T24124.hs - + testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,63 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline saturated applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Mainly for reasons of backwards compatibility, we recognise `seq#` during + Demand Analysis as not throwing a precise exception by the mechanism + implementing Note [Precise exceptions and strictness analysis]. + More concretely, `case seq# x s of (# s', x' #) -> y` is detected strict in + `y`, which is how all PrimOps except `raiseIO#` are treated. + +(SEQ4) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: return False for seq#. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + We are only inlining `seq#`, leaving opportunities for case-of-known-con + behind for `case seq# f 13 s of (# s', r #) -> rhs`. These are easily picked + up by Unarise and we get `case f 13 of sat { __DEFAULT -> Solo# [sat] }`, + which is good enough. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2219,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Opt.WorkWrap.Utils +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -602,16 +603,21 @@ exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException envs e | not (forcesRealWorld envs (exprType e)) = False -- 1. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just op <- isPrimOpId_maybe f , op /= RaiseIOOp = False -- 2. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just fcall <- isFCallId_maybe f , not (isSafeForeignCall fcall) = False -- 3. in the Note + | Var f <- fn + , f `hasKey` seqHashIdKey + = False -- 3. in the Note | otherwise = True -- _. in the Note + where + (fn, _) = collectArgs e -- | Recognises types that are -- * @State# RealWorld@ @@ -799,14 +805,16 @@ For an expression @f a1 ... an :: ty@ we determine that (Why not simply unboxed pairs as above? This is motivated by T13380{d,e}.) 2. False If f is a PrimOp, and it is *not* raiseIO# - 3. False If f is an unsafe FFI call ('PlayRisky') + 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic]. + 4. False If f is an unsafe FFI call ('PlayRisky') _. True Otherwise "give up". It is sound to return False in those cases, because 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions from pure code. 2. raiseIO# is the only primop that may throw a precise exception. - 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + 3. `seq# = \(!a) s -> (# a, s #)`, so it does not throw a precise exception. + 4. Unsafe FFI calls may not interact with the RTS (to throw, for example). See haddock on GHC.Types.ForeignCall.PlayRisky. We *need* to return False in those cases, because @@ -814,7 +822,8 @@ We *need* to return False in those cases, because 2. We would lose strictness for primops like getMaskingState#, which introduces a substantial regression in GHC.IO.Handle.Internals.wantReadableHandle. - 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + 3. `seq#` used to be a PrimOp and we want to stay backwards compatible. + 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData, where an intermittent FFI call to c_MD5Init would otherwise lose strictness on the arguments len and buf, leading to regressions in T9203 (2%) and i386's haddock.base (5%). Tested by T13380f. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,38 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp token] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + -- and turning token into a CpeArg as needed + = do { (floats1, thing) <- cpeBody env thing + ; (floats2, token) <- cpeArg env topDmd token + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1151,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1213,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1228,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1512,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1735,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1893,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2062,38 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) +{- +Eventually we want the following code, when #20749 is fixed. +Unfortunately, today it breaks T24124. + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. +-} + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + _is_lifted = not is_unlifted + _is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2111,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2144,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/core-to-stg/T24124.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Debug.Trace +import GHC.IO +import GHC.ST + +data StrictPair a b = !a :*: !b + +strictFun :: Int -> Int +{-# OPAQUE strictFun #-} +strictFun x = x*x*x + +opaqueId :: a -> a +{-# OPAQUE opaqueId #-} +{-# RULES + "opaqueId/noinline" opaqueId = noinline +#-} +-- work around noinline's special desugaring +opaqueId v = v + +evaluateST :: a -> ST s a +-- hide the fact that we are actually in IO because !11515 +-- causes seq# to look like it can throw precise exceptions +evaluateST x = ST (\s -> seq# x s) + +fun :: Int -> Int -> ST s Int +{-# OPAQUE fun #-} +fun = lazy $ \ !x y -> do + -- This should evaluate x before y. + _ <- evaluateST $ opaqueId (x :*: x) + _ <- evaluateST y + evaluateST $! strictFun x + +main :: IO () +main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13)) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -0,0 +1,2 @@ +x eval'd +y eval'd ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) +test('T24124', compile_and_run, compile_and_run, ['-O']) ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,21 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> - let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> + case T15226b.MkStrictPair [sat conrep] of sat { + __DEFAULT -> Solo# [sat]; + }; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91476c60e34524840ba4bfd8bd92269b12497d09 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91476c60e34524840ba4bfd8bd92269b12497d09 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 Dec 15 14:56:27 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 15 Dec 2023 09:56:27 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 2 commits: Cpr: Turn an assertion into a check to deal with some dead code (#23862) Message-ID: <657c691bdcd0e_e7a738235228124976@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 1405682a by Sebastian Graf at 2023-12-15T19:51:47+05:30 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. (cherry picked from commit 57c391c463f26b7025df9b340ad98416cff1d2b2) - - - - - dfd28f7a by Zubin Duggal at 2023-12-15T20:26:10+05:30 Prepare release 9.6.4 - - - - - 6 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - configure.ac - + docs/users_guide/9.6.4-notes.rst - docs/users_guide/release-notes.rst - + testsuite/tests/cpranal/should_compile/T23862.hs - testsuite/tests/cpranal/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -35,7 +35,6 @@ import GHC.Data.Graph.UnVar -- for UnVarSet import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) import Data.List ( mapAccumL ) @@ -271,11 +270,11 @@ cprAnalAlt cprAnalAlt env scrut_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where + ids = filter isId bndrs env_alt | DataAlt dc <- con - , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty - , assert (arity == 0 ) True + , arity == 0 -- See Note [Dead code may contain type confusions] = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr @@ -284,7 +283,7 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) | let sigs = zipWith (mkCprSig . idArity) ids field_cprs -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) | otherwise - = env + = extendSigEnvAllSame env ids topCprSig (rhs_ty, rhs') = cprAnal env_alt rhs -- @@ -431,6 +430,43 @@ cprFix orig_env orig_pairs (id', rhs', env') = cprAnalBind env id rhs {- +Note [Dead code may contain type confusions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In T23862, we have a nested case match that looks like this + + data CheckSingleton (check :: Bool) where + Checked :: CheckSingleton True + Unchecked :: CheckSingleton False + data family Result (check :: Bool) a + data instance Result True a = CheckedResult a + newtype instance Result True a = UncheckedResult a + + case m () of Checked co1 -> + case m () of Unchecked co2 -> + case ((\_ -> True) + |> .. UncheckedResult .. + |> sym co2 + |> co1) :: Result True (Bool -> Bool) of + CheckedResult f -> CheckedResult (f True) + +Clearly, the innermost case is dead code, because the `Checked` and `Unchecked` +cases are apart. +However, both constructors introduce mutually contradictory coercions `co1` and +`co2` along which GHC generates a type confusion: + + 1. (\_ -> True) :: Bool -> Bool + 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool) + 3. |> ... sym co1 ... :: Result check (Bool -> Bool) + 4. |> ... co2 ... :: Result True (Bool -> Bool) + +Note that we started with a function, injected into `Result` via a newtype +instance and then match on it with a datatype instance. + +We have to handle this case gracefully in `cprAnalAlt`, where for the innermost +case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that +abstracts the function `(\_ -> True)` with arity 1. +In this case, don't pretend we know anything about the fields of `CheckedResult`! + Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -0,0 +1,123 @@ +.. _release-9-6-4: + +Version 9.6.4 +============== + +The significant changes to the various parts of the compiler are listed below. +See the `migration guide +`_ on the GHC Wiki +for specific guidance on migrating programs to this release. + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM +11, 12, 13, 14 or 15. + +Significant Changes +~~~~~~~~~~~~~~~~~~~~ + +Issues fixed in this release include: + +Compiler +-------- + +- Fix a code generator bug on AArch64 platforms resulting in invalid conditional + jumps (:ghc-ticket:`23746`). +- Fix a simplifier bug that may cause segfaults and core lint failures due to + incorrect handling of join points (:ghc-ticket:`23952`). +- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`). +- Fix a bug where we could silently truncate 64 bit values to 32 bit on + 32 bit architectures. +- Fix a GHCi bug where a failure in the ``:add`` command would cause the + process to exit (:ghc-ticket:`24115`). +- Fix a bug causing suboptimal error messages for certain invalid cyclic + module graphs with hs-boot files (:ghc-ticket:`24196`). +- Fix a bug causing compiler panics with certain package databases involving + unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`, + :ghc-ticket:`11050`). +- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`, + :ghc-ticket:`24118`). +- Fix a bug leading to some template haskell splices failing on being reloaded + into GHCi due to not clearing the interactive context properly + (:ghc-ticket:`23405`). +- Fix a type checker crash on certain programs involving implicitly scoped type + 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`). + +Runtime system +-------------- + +- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`). +- Ensure the ``listAllBlocks`` function takes the non-moving heap into account + (:ghc-ticket:`22627`). +- Ensure the non-moving GC is not running when pausing +- Fix some non-moving loops and bugs on Windows and LLP64 platforms + (:ghc-ticket:`23003`, :ghc-ticket:`24042`). +- Fix a bug where certain programs could have incorrect async exception masking + (:ghc-ticket:`23513`). +- Ensure we respect maximum event length and don't overflow into program + memory (:ghc-ticket:`24197`). + +Build system and packaging +-------------------------- + +- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`, + :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`). + +Core libraries +-------------- + +- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in + out of bounds access (:ghc-ticket:`24066`). +- Bump ``base`` to 4.18.2.0 +- base: Update to Unicode 15.1.0 +- Bump ``filepath`` to 1.4.200.1 +- Bump ``unix`` to 2.8.4.0 +- Bump ``haddock`` to 2.29.2 + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + ===================================== docs/users_guide/release-notes.rst ===================================== @@ -7,3 +7,4 @@ Release notes 9.6.1-notes 9.6.2-notes 9.6.3-notes + 9.6.4-notes ===================================== testsuite/tests/cpranal/should_compile/T23862.hs ===================================== @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module T23862 where + +data Checked +data Unchecked + +data family Result check a +data instance Result Checked a = CheckedResult a +newtype instance Result Unchecked a = UncheckedResult a + +data CheckSingleton check where + Checked :: CheckSingleton Checked + Unchecked :: CheckSingleton Unchecked + +und :: Bool -> Bool +und x = und x + +app :: forall check. (() -> CheckSingleton check) -> Result check Bool +app m = let f :: Result check (Bool -> Bool) + f = case m () of + Checked -> CheckedResult und + Unchecked -> UncheckedResult und + in case m () of + Checked -> case f of + CheckedResult x -> CheckedResult (x True) + Unchecked -> UncheckedResult True ===================================== testsuite/tests/cpranal/should_compile/all.T ===================================== @@ -22,3 +22,5 @@ test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsu test('T18824', [ grep_errmsg(r'JoinId[^\n]*Cpr') ], compile, ['-ddump-exitify -dppr-cols=1000 -dsuppress-uniques']) test('T20539', [], compile, ['']) # simply should not crash + +test('T23862', [], compile, ['']) # simply should not crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ac485d289569dbed00a764f07ed388d41a563f6...dfd28f7a0ab6dc6fe2b946f562e84aa160b41657 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ac485d289569dbed00a764f07ed388d41a563f6...dfd28f7a0ab6dc6fe2b946f562e84aa160b41657 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 Dec 15 15:11:16 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Fri, 15 Dec 2023 10:11:16 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] ghcup-metadata: Use dynamically linked alpine bindists Message-ID: <657c6c9473525_e7a7385a8c48125927@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 87c98514 by Matthew Pickering at 2023-12-15T20:41:07+05:30 ghcup-metadata: Use dynamically linked alpine bindists In theory these will work much better on alpine to allow people to build statically linked applications there. We don't need to distribute a statically linked application ourselves in order to allow that. Fixes #23602 (cherry picked from commit e524fa7f67259a093aeb21aada139137626c581c) - - - - - 2 changed files: - .gitlab-ci.yml - .gitlab/gen_ci.hs Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1018,7 +1018,7 @@ ghcup-metadata-nightly: artifacts: false - job: nightly-x86_64-windows-validate artifacts: false - - job: nightly-x86_64-linux-alpine3_12-int_native-validate+fully_static + - job: nightly-x86_64-linux-alpine3_12-validate artifacts: false - job: nightly-x86_64-linux-deb9-validate artifacts: false ===================================== .gitlab/gen_ci.hs ===================================== @@ -955,7 +955,7 @@ platform_mapping :: Map String (JobGroup BindistInfo) platform_mapping = Map.map go $ Map.fromListWith combine [ (uncurry mkPlatform (jobPlatform (jobInfo $ v j)), j) | j <- filter hasReleaseBuild job_groups ] where - whitelist = [ "x86_64-linux-alpine3_12-int_native-validate+fully_static" + whitelist = [ "x86_64-linux-alpine3_12-validate" , "x86_64-linux-deb10-validate" , "x86_64-linux-deb11-validate" , "x86_64-linux-fedora33-release" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87c9851436246ac862ae1107232da0f28182c65f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/87c9851436246ac862ae1107232da0f28182c65f 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 Dec 15 17:02:12 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Fri, 15 Dec 2023 12:02:12 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <657c86947f3f4_e7a73af58b9c1426d3@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: 0fd053c4 by Sebastian Graf at 2023-12-15T18:01:38+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 20 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - + testsuite/tests/core-to-stg/T24124.hs - + testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,13 +2047,18 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } @@ -2069,25 +2073,63 @@ Things to note In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline saturated applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` evaluates its argument and demand analysis would report it as strict, + <1L>. But it is important that we do /not/ expose that strictness + in its strictness signature. Why not? Because `seq#` is intended to mean + "evaluate this argument now -- not earlier". For example: + do { evaluate x; evaluate y } + should evaluate `x` and then `y`. If `seq#` was visibly strict, they + might be evaluated in the opposite order. + Easily achieved for a magic Id, in GHC.Types.Id.Make. + +(SEQ3) + Mainly for reasons of backwards compatibility, we recognise `seq#` during + Demand Analysis as not throwing a precise exception by the mechanism + implementing Note [Precise exceptions and strictness analysis]. + More concretely, `case seq# x s of (# s', x' #) -> y` is detected strict in + `y`, which is how all PrimOps except `raiseIO#` are treated. + +(SEQ4) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: return False for seq#. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + We are only inlining `seq#`, leaving opportunities for case-of-known-con + behind for `case seq# f 13 s of (# s', r #) -> rhs`. These are easily picked + up by Unarise and we get `case f 13 of sat { __DEFAULT -> Solo# [sat] }`, + which is good enough. + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2219,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Opt.WorkWrap.Utils +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -602,16 +603,21 @@ exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException envs e | not (forcesRealWorld envs (exprType e)) = False -- 1. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just op <- isPrimOpId_maybe f , op /= RaiseIOOp = False -- 2. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just fcall <- isFCallId_maybe f , not (isSafeForeignCall fcall) = False -- 3. in the Note + | Var f <- fn + , f `hasKey` seqHashIdKey + = False -- 3. in the Note | otherwise = True -- _. in the Note + where + (fn, _) = collectArgs e -- | Recognises types that are -- * @State# RealWorld@ @@ -799,14 +805,16 @@ For an expression @f a1 ... an :: ty@ we determine that (Why not simply unboxed pairs as above? This is motivated by T13380{d,e}.) 2. False If f is a PrimOp, and it is *not* raiseIO# - 3. False If f is an unsafe FFI call ('PlayRisky') + 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic]. + 4. False If f is an unsafe FFI call ('PlayRisky') _. True Otherwise "give up". It is sound to return False in those cases, because 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions from pure code. 2. raiseIO# is the only primop that may throw a precise exception. - 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + 3. `seq# = \(!a) s -> (# a, s #)`, so it does not throw a precise exception. + 4. Unsafe FFI calls may not interact with the RTS (to throw, for example). See haddock on GHC.Types.ForeignCall.PlayRisky. We *need* to return False in those cases, because @@ -814,7 +822,8 @@ We *need* to return False in those cases, because 2. We would lose strictness for primops like getMaskingState#, which introduces a substantial regression in GHC.IO.Handle.Internals.wantReadableHandle. - 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + 3. `seq#` used to be a PrimOp and we want to stay backwards compatible. + 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData, where an intermittent FFI call to c_MD5Init would otherwise lose strictness on the arguments len and buf, leading to regressions in T9203 (2%) and i386's haddock.base (5%). Tested by T13380f. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,38 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp token] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + -- and turning token into a CpeArg as needed + = do { (floats1, thing) <- cpeBody env thing + ; (floats2, token) <- cpeArg env topDmd token + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1151,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1213,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1228,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1512,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1735,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1893,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2062,38 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) +{- +Eventually we want the following code, when #20749 is fixed. +Unfortunately, today it breaks T24124. + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. +-} + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + _is_lifted = not is_unlifted + _is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2111,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2144,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/core-to-stg/T24124.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Debug.Trace +import GHC.IO +import GHC.ST + +data StrictPair a b = !a :*: !b + +strictFun :: Int -> Int +{-# OPAQUE strictFun #-} +strictFun x = x*x*x + +opaqueId :: a -> a +{-# OPAQUE opaqueId #-} +{-# RULES + "opaqueId/noinline" opaqueId = noinline +#-} +-- work around noinline's special desugaring +opaqueId v = v + +evaluateST :: a -> ST s a +-- hide the fact that we are actually in IO because !11515 +-- causes seq# to look like it can throw precise exceptions +evaluateST x = ST (\s -> seq# x s) + +fun :: Int -> Int -> ST s Int +{-# OPAQUE fun #-} +fun = lazy $ \ !x y -> do + -- This should evaluate x before y. + _ <- evaluateST $ opaqueId (x :*: x) + _ <- evaluateST y + evaluateST $! strictFun x + +main :: IO () +main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13)) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -0,0 +1,2 @@ +x eval'd +y eval'd ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) +test('T24124', normal, compile_and_run, ['-O']) ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,21 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> - let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> + case T15226b.MkStrictPair [sat conrep] of sat { + __DEFAULT -> Solo# [sat]; + }; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fd053c463bfd7cb1de25ec8c9174e31ea1a0d7c -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0fd053c463bfd7cb1de25ec8c9174e31ea1a0d7c 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 Dec 15 17:36:57 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Fri, 15 Dec 2023 12:36:57 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/check-@-binders] fixup! Lazy skolemisation for @a-binders (17594) Message-ID: <657c8eb92f2ab_e7a73bf20bb0144523@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/check- at -binders at Glasgow Haskell Compiler / GHC Commits: ca8c4869 by Andrei Borzenkov at 2023-12-15T21:36:44+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 9 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 - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -633,7 +633,7 @@ tcPolyCheck prag_fn ; mult <- tcMultAnn (HsNoMultAnn noExtField) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems - tcSkolemiseScoped ctxt (idType poly_id) $ \imp_ty_vars rho_ty -> + tcSkolemiseScoped ctxt (idType poly_id) $ \ty_vars rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah -- NB: tcSkolemiseScoped makes fresh type variables @@ -646,7 +646,7 @@ tcPolyCheck prag_fn setSrcSpanA bind_loc $ tc_matches_fun (L nm_loc (idName mono_id)) mult matches - (map mkInvisExpPatType imp_ty_vars) (Check rho_ty) + (filterInvisInferredTyBndrs ty_vars) (Check 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, tcPolyExpr, tcExpr, + tcPolyLExpr, tcPolyExpr, tcLExprWithTyVarsNC, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -90,6 +90,7 @@ import GHC.Utils.Panic import Control.Monad import qualified Data.List.NonEmpty as NE +import GHC.Types.Var (filterInvisInferredTyBndrs) {- ************************************************************************ @@ -176,11 +177,24 @@ tcInferRhoNC (L loc expr) ********************************************************************* -} tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) -tcPolyExpr (HsPar x expr) res_ty - = do { expr' <- tcPolyLExprNC expr res_ty +tcPolyExpr expr res_ty + = do { traceTc "tcPolyExpr" (ppr res_ty) + ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \bndrs res_ty -> + tcExprWithTyVars expr (filterInvisInferredTyBndrs bndrs) res_ty + ; return $ mkHsWrap wrap expr' } + +tcLExprWithTyVarsNC :: LHsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcLExprWithTyVarsNC (L loc expr) ty_vars res_ty + = setSrcSpanA loc $ + do { expr' <- tcExprWithTyVars expr ty_vars res_ty + ; return (L loc expr') } + +tcExprWithTyVars :: HsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (HsExpr GhcTc) +tcExprWithTyVars (HsPar x expr) ty_vars res_ty + = do { expr' <- tcLExprWithTyVarsNC expr ty_vars res_ty ; return (HsPar x expr') } -tcPolyExpr e@(HsLam x lam_variant matches) res_ty +tcExprWithTyVars e@(HsLam x lam_variant matches) _ res_ty = do { (wrap, matches') <- tcMatchLambda herald match_ctxt matches res_ty ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } @@ -188,11 +202,9 @@ tcPolyExpr e@(HsLam x lam_variant matches) res_ty match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody } herald = ExpectedFunTyLam lam_variant e -tcPolyExpr expr res_ty - = do { traceTc "tcPolyExpr" (ppr res_ty) - ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ mkHsWrap wrap expr' } +tcExprWithTyVars expr _ res_ty + = tcExpr expr res_ty + tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -3,7 +3,7 @@ import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR , SyntaxOpType - , ExpType, ExpRhoType, ExpSigmaType ) + , ExpType, ExpRhoType, ExpSigmaType, TcTyVar ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) @@ -25,6 +25,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcLExprWithTyVarsNC :: LHsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (LHsExpr GhcTc) + tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) ===================================== 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, tcCheckMonoExprNC, tcCheckPolyExprNC ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcLExprWithTyVarsNC ) import GHC.Prelude import GHC.Hs @@ -87,6 +87,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import Control.Monad +import GHC.Types.Var (filterInvisInferredTyBndrs) @@ -984,17 +985,9 @@ tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id - ; (wrap, expr') <- check_expr poly_ty + ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \ty_vars rho_ty -> + tcLExprWithTyVarsNC expr (filterInvisInferredTyBndrs ty_vars) (Check rho_ty) ; return (mkLHsWrap wrap expr', poly_ty) } - where - check_expr poly_ty = do - stv <- xoptM LangExt.ScopedTypeVariables - if stv then - tcSkolemiseScoped ctxt poly_ty $ \_ rho_ty -> - tcCheckMonoExprNC expr rho_ty - else - do { res <- tcCheckPolyExprNC expr poly_ty - ; pure (idHsWrapper, res)} tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -106,11 +106,11 @@ tcMatchesFun fun_name mult matches = tc_matches_fun fun_name mult matches [] tc_matches_fun :: LocatedN Name -- MatchContext Id -> Mult -- The multiplicity of the binder -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] + -> [TcTyVar] -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty +tc_matches_fun fun_name mult matches ty_vars exp_ty = 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 @@ -121,7 +121,7 @@ tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty ; checkArgCounts what matches ; (wrapper, (mult_co_wrap, r)) <- - match_expected_fun_tys herald ctxt arity implicit_pat_tys exp_ty $ \ pat_tys rhs_ty -> + match_expected_fun_tys herald ctxt arity ty_vars exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that tcScalingUsage mult $ @@ -163,11 +163,21 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType + -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty + = tc_match_lambda herald match_ctxt match [] res_ty + +tc_match_lambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + -> TcMatchCtxt HsExpr + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [TcTyVar] + -> ExpRhoType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tc_match_lambda herald match_ctxt match ty_vars res_ty = do { checkArgCounts (mc_what match_ctxt) match - ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> + ; (wrapper, (mult_co_wrap, r)) <- match_expected_fun_tys herald GenSigCtxt n_pats ty_vars res_ty $ + \ pat_tys rhs_ty -> -- checking argument counts since this is also used for \cases tcMatches match_ctxt pat_tys rhs_ty match ; return (wrapper <.> mult_co_wrap, r) } ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -1,7 +1,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, TcTyVar ) import GHC.Tc.Types ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN ) @@ -21,6 +21,6 @@ tcMatchesFun :: LocatedN Name tc_matches_fun :: LocatedN Name -> Mult -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] + -> [TcTyVar] -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -32,7 +32,8 @@ module GHC.Tc.Utils.TcType ( ExpRhoType, checkingExpType_maybe, checkingExpType, - ExpPatType(..), mkInvisExpPatType, isExpForAllPatTyInvis, isExpFunPatTy, + ExpPatType(..), mkInvisExpPatType, mkForAllPatTysFromSkolemised, + isExpForAllPatTyInvis, isExpFunPatTy, SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -459,8 +460,11 @@ data ExpPatType = ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B -mkInvisExpPatType :: InvisTyBinder -> ExpPatType -mkInvisExpPatType = ExpForAllPatTy . fmap Invisible +mkInvisExpPatType :: TcTyVar -> ExpPatType +mkInvisExpPatType = ExpForAllPatTy . mkForAllTyBinder (Invisible SpecifiedSpec) + +mkForAllPatTysFromSkolemised :: [InvisTyBinder] -> [ExpPatType] +mkForAllPatTysFromSkolemised = map mkInvisExpPatType . filterInvisInferredTyBndrs isExpForAllPatTyInvis :: ExpPatType -> Bool isExpForAllPatTyInvis (ExpForAllPatTy (Bndr _ Invisible{})) = True ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -383,25 +383,26 @@ match_expected_fun_tys :: forall a. ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> Arity - -> [ExpPatType] -- implicit, previously skolemised pattern types + -> [TcTyVar] -- implicit, previously skolemised pattern types -> ExpRhoType -> ([ExpPatType] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (wrap, _) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -match_expected_fun_tys herald ctx arity imp_pat_tys orig_ty thing_inside +match_expected_fun_tys herald ctx arity tv_vars orig_ty thing_inside = case orig_ty of -- go collects pat tys in reversed order - Check ty -> go (reverse imp_pat_tys) arity ty - _ -> defer (reverse imp_pat_tys) arity orig_ty + Check ty -> go imp_pat_tys arity ty + _ -> defer imp_pat_tys arity orig_ty where + imp_pat_tys = reverse $ map mkInvisExpPatType tv_vars -- Skolemise any /invisible/ foralls /before/ the zero-arg case -- so that we guarantee to return a rho-type go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \imp_ty_pats ty' -> - go (reverse (map mkInvisExpPatType imp_ty_pats) ++ acc_arg_tys) n ty' + go (reverse (mkForAllPatTysFromSkolemised imp_ty_pats) ++ acc_arg_tys) n ty' ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ coreView, so @@ -1560,16 +1561,16 @@ tcTopSkolemise ctxt expected_ty thing_inside -- | Variant of 'tcTopSkolemise' that takes an ExpType tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) + -> ([TcInvisTVBinder] -> ExpRhoType -> TcM result) -> TcM (HsWrapper, result) tcSkolemiseExpType _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et + = (idHsWrapper, ) <$> thing_inside [] et tcSkolemiseExpType ctxt (Check ty) thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = tcDeeplySkolemise | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \_ rho_ty -> - thing_inside (Check rho_ty) } + ; skolemise ctxt ty $ \ty_bndrs rho_ty -> + thing_inside ty_bndrs (Check rho_ty) } checkConstraints :: SkolemInfoAnon -> [TcTyVar] -- Skolems ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -94,7 +94,8 @@ module GHC.Types.Var ( mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, isTyVarBinder, - tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, + tyVarSpecToBinder, tyVarSpecToBinders, filterInvisInferredTyBndrs, + tyVarReqToBinder, tyVarReqToBinders, mapVarBndr, mapVarBndrs, -- ** ExportFlag @@ -741,6 +742,9 @@ type ReqTVBinder = VarBndr TyVar () tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag] tyVarSpecToBinders = map tyVarSpecToBinder +filterInvisInferredTyBndrs :: [InvisTyBinder] -> [TcTyVar] +filterInvisInferredTyBndrs = binderVars . filterOut (\bndr -> binderFlag bndr == InferredSpec) + tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ForAllTyFlag tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca8c4869a22c678f81231cfa49cd82ec2fc84ee8 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca8c4869a22c678f81231cfa49cd82ec2fc84ee8 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 Dec 15 18:00:51 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Fri, 15 Dec 2023 13:00:51 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/lazy-skol-exp-pat-tys] fixup! Lazy skolemisation for @a-binders (17594) Message-ID: <657c94535fb14_e7a73c86aae01559c9@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/lazy-skol-exp-pat-tys at Glasgow Haskell Compiler / GHC Commits: 4dc75d27 by Andrei Borzenkov at 2023-12-15T22:00:30+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 9 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 - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -633,7 +633,7 @@ tcPolyCheck prag_fn ; mult <- tcMultAnn (HsNoMultAnn noExtField) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems - tcSkolemiseScoped ctxt (idType poly_id) $ \imp_ty_vars rho_ty -> + tcSkolemiseScoped ctxt (idType poly_id) $ \ty_vars rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah -- NB: tcSkolemiseScoped makes fresh type variables @@ -646,7 +646,7 @@ tcPolyCheck prag_fn setSrcSpanA bind_loc $ tc_matches_fun (L nm_loc (idName mono_id)) mult matches - (map mkInvisExpPatType imp_ty_vars) (mkCheckExpType rho_ty) + (filterInvisInferredTyBndrs ty_vars) (Check 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, tcPolyExpr, tcExpr, + tcPolyLExpr, tcPolyExpr, tcLExprWithTyVarsNC, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -90,6 +90,7 @@ import GHC.Utils.Panic import Control.Monad import qualified Data.List.NonEmpty as NE +import GHC.Types.Var (filterInvisInferredTyBndrs) {- ************************************************************************ @@ -176,11 +177,24 @@ tcInferRhoNC (L loc expr) ********************************************************************* -} tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) -tcPolyExpr (HsPar x expr) res_ty - = do { expr' <- tcPolyLExprNC expr res_ty +tcPolyExpr expr res_ty + = do { traceTc "tcPolyExpr" (ppr res_ty) + ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \bndrs res_ty -> + tcExprWithTyVars expr (filterInvisInferredTyBndrs bndrs) res_ty + ; return $ mkHsWrap wrap expr' } + +tcLExprWithTyVarsNC :: LHsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcLExprWithTyVarsNC (L loc expr) ty_vars res_ty + = setSrcSpanA loc $ + do { expr' <- tcExprWithTyVars expr ty_vars res_ty + ; return (L loc expr') } + +tcExprWithTyVars :: HsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (HsExpr GhcTc) +tcExprWithTyVars (HsPar x expr) ty_vars res_ty + = do { expr' <- tcLExprWithTyVarsNC expr ty_vars res_ty ; return (HsPar x expr') } -tcPolyExpr e@(HsLam x lam_variant matches) res_ty +tcExprWithTyVars e@(HsLam x lam_variant matches) _ res_ty = do { (wrap, matches') <- tcMatchLambda herald match_ctxt matches res_ty ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } @@ -188,11 +202,9 @@ tcPolyExpr e@(HsLam x lam_variant matches) res_ty match_ctxt = MC { mc_what = LamAlt lam_variant, mc_body = tcBody } herald = ExpectedFunTyLam lam_variant e -tcPolyExpr expr res_ty - = do { traceTc "tcPolyExpr" (ppr res_ty) - ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ mkHsWrap wrap expr' } +tcExprWithTyVars expr _ res_ty + = tcExpr expr res_ty + tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Gen/Expr.hs-boot ===================================== @@ -3,7 +3,7 @@ import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR , SyntaxOpType - , ExpType, ExpRhoType, ExpSigmaType ) + , ExpType, ExpRhoType, ExpSigmaType, TcTyVar ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) @@ -25,6 +25,8 @@ tcCheckMonoExpr, tcCheckMonoExprNC :: tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcLExprWithTyVarsNC :: LHsExpr GhcRn -> [TcTyVar] -> ExpRhoType -> TcM (LHsExpr GhcTc) + tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) ===================================== 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, tcCheckMonoExprNC, tcCheckPolyExprNC ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcLExprWithTyVarsNC ) import GHC.Prelude import GHC.Hs @@ -87,6 +87,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import Control.Monad +import GHC.Types.Var (filterInvisInferredTyBndrs) @@ -984,17 +985,9 @@ tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id - ; (wrap, expr') <- check_expr poly_ty + ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \ty_vars rho_ty -> + tcLExprWithTyVarsNC expr (filterInvisInferredTyBndrs ty_vars) (Check rho_ty) ; return (mkLHsWrap wrap expr', poly_ty) } - where - check_expr poly_ty = do - stv <- xoptM LangExt.ScopedTypeVariables - if stv then - tcSkolemiseScoped ctxt poly_ty $ \_ rho_ty -> - tcCheckMonoExprNC expr rho_ty - else - do { res <- tcCheckPolyExprNC expr poly_ty - ; pure (idHsWrapper, res)} tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -106,11 +106,11 @@ tcMatchesFun fun_name mult matches = tc_matches_fun fun_name mult matches [] tc_matches_fun :: LocatedN Name -- MatchContext Id -> Mult -- The multiplicity of the binder -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] + -> [TcTyVar] -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -- Returns type of body -tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty +tc_matches_fun fun_name mult matches ty_vars exp_ty = 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 @@ -121,7 +121,7 @@ tc_matches_fun fun_name mult matches implicit_pat_tys exp_ty ; checkArgCounts what matches ; (wrapper, (mult_co_wrap, r)) <- - match_expected_fun_tys herald ctxt arity implicit_pat_tys exp_ty $ \ pat_tys rhs_ty -> + match_expected_fun_tys herald ctxt arity ty_vars exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that tcScalingUsage mult $ @@ -163,11 +163,21 @@ tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify -> TcMatchCtxt HsExpr -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType + -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty + = tc_match_lambda herald match_ctxt match [] res_ty + +tc_match_lambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + -> TcMatchCtxt HsExpr + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [TcTyVar] + -> ExpRhoType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tc_match_lambda herald match_ctxt match ty_vars res_ty = do { checkArgCounts (mc_what match_ctxt) match - ; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> + ; (wrapper, (mult_co_wrap, r)) <- match_expected_fun_tys herald GenSigCtxt n_pats ty_vars res_ty $ + \ pat_tys rhs_ty -> -- checking argument counts since this is also used for \cases tcMatches match_ctxt pat_tys rhs_ty match ; return (wrapper <.> mult_co_wrap, r) } ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -1,7 +1,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, TcTyVar ) import GHC.Tc.Types ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN ) @@ -21,6 +21,6 @@ tcMatchesFun :: LocatedN Name tc_matches_fun :: LocatedN Name -> Mult -> MatchGroup GhcRn (LHsExpr GhcRn) - -> [ExpPatType] + -> [TcTyVar] -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -33,7 +33,8 @@ module GHC.Tc.Utils.TcType ( mkCheckExpType, checkingExpType_maybe, checkingExpType, - ExpPatType(..), mkInvisExpPatType, isExpForAllPatTyInvis, isExpFunPatTy, + ExpPatType(..), mkInvisExpPatType, mkForAllPatTysFromSkolemised, + isExpForAllPatTyInvis, isExpFunPatTy, SyntaxOpType(..), synKnownType, mkSynFunTys, @@ -464,8 +465,11 @@ data ExpPatType = ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B -mkInvisExpPatType :: InvisTyBinder -> ExpPatType -mkInvisExpPatType = ExpForAllPatTy . fmap Invisible +mkInvisExpPatType :: TcTyVar -> ExpPatType +mkInvisExpPatType = ExpForAllPatTy . mkForAllTyBinder (Invisible SpecifiedSpec) + +mkForAllPatTysFromSkolemised :: [InvisTyBinder] -> [ExpPatType] +mkForAllPatTysFromSkolemised = map mkInvisExpPatType . filterInvisInferredTyBndrs isExpForAllPatTyInvis :: ExpPatType -> Bool isExpForAllPatTyInvis (ExpForAllPatTy (Bndr _ Invisible{})) = True ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -383,25 +383,26 @@ match_expected_fun_tys :: forall a. ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] -> UserTypeCtxt -> Arity - -> [ExpPatType] -- implicit, previously skolemised pattern types + -> [TcTyVar] -- implicit, previously skolemised pattern types -> ExpRhoType -> ([ExpPatType] -> ExpRhoType -> TcM a) -> TcM (HsWrapper, a) -- If matchExpectedFunTys n ty = (wrap, _) -- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, -- where [t1, ..., tn], ty_r are passed to the thing_inside -match_expected_fun_tys herald ctx arity imp_pat_tys orig_ty thing_inside +match_expected_fun_tys herald ctx arity tv_vars orig_ty thing_inside = case orig_ty of -- go collects pat tys in reversed order - Check ty -> go (reverse imp_pat_tys) arity ty - _ -> defer (reverse imp_pat_tys) arity orig_ty + Check ty -> go imp_pat_tys arity ty + _ -> defer imp_pat_tys arity orig_ty where + imp_pat_tys = reverse $ map mkInvisExpPatType tv_vars -- Skolemise any /invisible/ foralls /before/ the zero-arg case -- so that we guarantee to return a rho-type go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty -- Invisible binders only! , not (null tvs && null theta) -- Visible ones handled below = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \imp_ty_pats ty' -> - go (reverse (map mkInvisExpPatType imp_ty_pats) ++ acc_arg_tys) n ty' + go (reverse (mkForAllPatTysFromSkolemised imp_ty_pats) ++ acc_arg_tys) n ty' ; return (wrap_gen <.> wrap_res, result) } -- No more args; do this /before/ coreView, so @@ -1560,16 +1561,16 @@ tcTopSkolemise ctxt expected_ty thing_inside -- | Variant of 'tcTopSkolemise' that takes an ExpType tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) + -> ([TcInvisTVBinder] -> ExpRhoType -> TcM result) -> TcM (HsWrapper, result) tcSkolemiseExpType _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et + = (idHsWrapper, ) <$> thing_inside [] et tcSkolemiseExpType ctxt (Check ty) thing_inside = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = tcDeeplySkolemise | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \_ rho_ty -> - thing_inside (mkCheckExpType rho_ty) } + ; skolemise ctxt ty $ \ty_bndrs rho_ty -> + thing_inside ty_bndrs (Check rho_ty) } checkConstraints :: SkolemInfoAnon -> [TcTyVar] -- Skolems ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -93,7 +93,8 @@ module GHC.Types.Var ( mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, isTyVarBinder, - tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, + tyVarSpecToBinder, tyVarSpecToBinders, filterInvisInferredTyBndrs, + tyVarReqToBinder, tyVarReqToBinders, mapVarBndr, mapVarBndrs, -- ** ExportFlag @@ -735,6 +736,9 @@ type ReqTVBinder = VarBndr TyVar () tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag] tyVarSpecToBinders = map tyVarSpecToBinder +filterInvisInferredTyBndrs :: [InvisTyBinder] -> [TcTyVar] +filterInvisInferredTyBndrs = binderVars . filterOut (\bndr -> binderFlag bndr == InferredSpec) + tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ForAllTyFlag tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4dc75d27d4d5ba0b55b160a095302c9e2ac1d7a5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4dc75d27d4d5ba0b55b160a095302c9e2ac1d7a5 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 Dec 15 18:05:32 2023 From: gitlab at gitlab.haskell.org (Andrei Borzenkov (@sand-witch)) Date: Fri, 15 Dec 2023 13:05:32 -0500 Subject: [Git][ghc/ghc][wip/sand-witch/check-@-binders] 2 commits: fixup! Lazy skolemisation for @a-binders (17594) Message-ID: <657c956c8482e_e7a73cab46fc15646c@gitlab.mail> Andrei Borzenkov pushed to branch wip/sand-witch/check- at -binders at Glasgow Haskell Compiler / GHC Commits: 4dc75d27 by Andrei Borzenkov at 2023-12-15T22:00:30+04:00 fixup! Lazy skolemisation for @a-binders (17594) - - - - - 69b07bc3 by Andrei Borzenkov at 2023-12-15T22:05:19+04:00 Parser, renamer, type checker for @a-binders (17594) As a part of GHC Proposal 448 were introduced invisible type patterns (@a-patterns) in functions and lambdas: id1 :: a -> a id1 @t x = x :: t id2 :: a -> a id2 = \ @t x -> x :: t Was introduced new data type ArgPat and now Match stores it instead of Pat. ArgPat has two constructors: VisPat for common patterns and InvisPat for @-patterns. Parsing is implemented in production argpat. Was introduced ArgPatBuilder to help post process new patterns. Renaming of ArgPat is implemented in rnArgPats function. Type checking is a bit tricky due to eager scolemisation. It's implemented in new functions tcTopSkolemiseExpPatTys, tcSkolemiseScopedExpPatTys, and tcArgPats. For more information about hack with collecting `ExpPatType`s see Note [Type-checking invisible type patterns: check mode] Type-checking is currently limited by check mode and -XNoDeepSubsumption. Examples of new code: id1 :: forall a. a -> a id1 @t x = x :: t id2 :: a -> a id2 @t x = x :: t id3 :: a -> a id3 = \ @t x -> x id_RankN :: (forall a. a -> a) -> a -> a id_RankN @t f = f @t id4 = id_RankN \ @t x -> x :: t id_list :: [forall a. a -> a] id_list = [\ @t x -> x] Metric Increase: LargeRecord RecordUpdPerf - - - - - 30 changed files: - compiler/GHC/Builtin/Names/TH.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Arrows.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv/Functor.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.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 The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca8c4869a22c678f81231cfa49cd82ec2fc84ee8...69b07bc378df60304b96aeccbb41a007bb07992b -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ca8c4869a22c678f81231cfa49cd82ec2fc84ee8...69b07bc378df60304b96aeccbb41a007bb07992b 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 Dec 15 20:24:09 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Fri, 15 Dec 2023 15:24:09 -0500 Subject: [Git][ghc/ghc][wip/24254] Document late plugins Message-ID: <657cb5e9d2ff7_e7a73fd21f54170564@gitlab.mail> Finley McIlwaine pushed to branch wip/24254 at Glasgow Haskell Compiler / GHC Commits: ebd44d14 by Finley McIlwaine at 2023-12-15T12:23:18-08:00 Document late plugins - - - - - 4 changed files: - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/late-plugin/LatePlugin.hs Changes: ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -167,6 +167,8 @@ data Plugin = Plugin { -- ^ A plugin that runs after interface creation and after late cost centre -- insertion. Useful for transformations that should not impact interfaces -- or optimization at all. + -- + -- @since 9.10.1 , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -2,6 +2,7 @@ module LatePlugin where import Data.Bool import GHC.Core +import GHC.Core.TyCo.Compare import GHC.Driver.Monad import GHC.Plugins import GHC.Types.Avail @@ -43,7 +44,7 @@ editCoreBinding early modName pgm = do where go :: [CoreBind] -> [CoreBind] go (b@(NonRec v e) : bs) - | occNameString (getOccName v) == "testBinding" = + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs go (b:bs) = b : go bs go [] = [] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebd44d1455a46c4316094fdaddb0a7962e6733f0 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ebd44d1455a46c4316094fdaddb0a7962e6733f0 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 Dec 15 20:24:51 2023 From: gitlab at gitlab.haskell.org (Finley McIlwaine (@FinleyMcIlwaine)) Date: Fri, 15 Dec 2023 15:24:51 -0500 Subject: [Git][ghc/ghc][wip/24254] 6 commits: Document ghc package's PVP-noncompliance Message-ID: <657cb61384159_e7a73fd611a4170926@gitlab.mail> Finley McIlwaine pushed to branch wip/24254 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 19 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - compiler/ghc.cabal.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - libraries/base/tests/all.T - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/T20509/all.T - testsuite/tests/backpack/cabal/bkpcabal02/all.T - testsuite/tests/backpack/cabal/bkpcabal03/all.T - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs - testsuite/tests/rts/all.T Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== compiler/ghc.cabal.in ===================================== @@ -20,6 +20,11 @@ Description: . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== libraries/base/tests/all.T ===================================== @@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', omit_ghci, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) -test('AtomicModifyIORef', normal, compile_and_run, ['']) +test('AtomicModifyIORef', js_fragile(24259), compile_and_run, ['']) test('AtomicSwapIORef', normal, compile_and_run, ['']) test('T23454', normal, compile_fail, ['']) test('T23687', normal, compile_and_run, ['']) ===================================== testsuite/driver/testlib.py ===================================== @@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ): else: return normal; +# expect occasional failures for the JS backend +def js_fragile( bug: IssueNumber ): + if js_arch(): + return fragile(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the ===================================== testsuite/tests/backpack/cabal/T20509/all.T ===================================== @@ -1,6 +1,7 @@ test('T20509', [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) , run_timeout_multiplier(2) + , js_fragile(24259) ], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal02/all.T ===================================== @@ -1,5 +1,6 @@ test('bkpcabal02', [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), - normalise_version('bkpcabal01')], + normalise_version('bkpcabal01'), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal03/all.T ===================================== @@ -1,4 +1,5 @@ test('bkpcabal03', - [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])], + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'), # times out with ghci test('T4030', omit_ghci, compile_and_run, ['-O']) -test('throwto002', normal, compile_and_run, ['']) +test('throwto002', js_fragile(24259), compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2))) test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_fragile(24259) ], compile_and_run, ['-package ghc -package exceptions']) ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) -test('T22671', normal, compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers']) +test('T22671', js_fragile(24259), compile_and_run, ['']) +test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers']) test('T24066', normal, compile_and_run, ['']) ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 ===================================== testsuite/tests/rts/all.T ===================================== @@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip) , omit_ghci , req_th , when(platform('x86_64-unknown-linux'), fragile(22283)) + , js_fragile(24259) ] , compile_and_run, [config.ghc_th_way_flags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebd44d1455a46c4316094fdaddb0a7962e6733f0...7c29da9f2650e6b849d50efbbe1ac82b4f52f8fc -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ebd44d1455a46c4316094fdaddb0a7962e6733f0...7c29da9f2650e6b849d50efbbe1ac82b4f52f8fc 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 Dec 15 21:16:32 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 15 Dec 2023 16:16:32 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-thunk-update] Fix thunk update ordering Message-ID: <657cc230951dd_e7a731152d10c1733db@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-thunk-update at Glasgow Haskell Compiler / GHC Commits: 14b1038e by Ben Gamari at 2023-12-15T16:16:14-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. - - - - - 20 changed files: - compiler/GHC/StgToCmm/Bind.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Heap.c - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/StableName.c - rts/StgMiscClosures.cmm - rts/ThreadPaused.c - rts/Threads.c - rts/Updates.cmm - rts/Updates.h - rts/include/Cmm.h - rts/include/rts/TSANUtils.h - rts/include/stg/SMP.h - rts/sm/Evac.c - rts/sm/NonMovingMark.c - rts/sm/Storage.c - utils/genapply/Main.hs Changes: ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -721,11 +721,19 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) + emitAtomicStore platform MemOrderRelease + (cmmOffsetW platform node (fixedHdrSizeW profile)) + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. - let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) - [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] + emitAtomicStore platform MemOrderRelease + node + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) + +emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () +emitAtomicStore platform mord addr val = + emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + where + w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), ===================================== rts/Apply.cmm ===================================== @@ -108,7 +108,7 @@ again: IND, IND_STATIC: { - fun = StgInd_indirectee(fun); + fun = %acquire StgInd_indirectee(fun); goto again; } case BCO: @@ -693,7 +693,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") } // Can't add StgInd_indirectee(ap) to UpdRemSet here because the old value is // not reachable. - StgInd_indirectee(ap) = CurrentTSO; + %release StgInd_indirectee(ap) = CurrentTSO; SET_INFO_RELEASE(ap, __stg_EAGER_BLACKHOLE_info); /* ensure there is at least AP_STACK_SPLIM words of headroom available ===================================== rts/Compact.cmm ===================================== @@ -100,7 +100,7 @@ eval: // Follow indirections: case IND, IND_STATIC: { - p = StgInd_indirectee(p); + p = %acquire StgInd_indirectee(p); goto eval; } ===================================== rts/Heap.c ===================================== @@ -173,7 +173,7 @@ StgWord collect_pointers(StgClosure *closure, StgClosure *ptrs[]) { case IND: case IND_STATIC: case BLACKHOLE: - ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); + ptrs[nptrs++] = (StgClosure *) ACQUIRE_LOAD(&((StgInd *)closure)->indirectee); break; case MUT_ARR_PTRS_CLEAN: ===================================== rts/Interpreter.c ===================================== @@ -420,7 +420,7 @@ eval_obj: case IND: case IND_STATIC: { - tagged_obj = ((StgInd*)obj)->indirectee; + tagged_obj = ACQUIRE_LOAD(&((StgInd*)obj)->indirectee); goto eval_obj; } ===================================== rts/Messages.c ===================================== @@ -191,9 +191,6 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *p; const StgInfoTable *info; do { - // If we are being called from stg_BLACKHOLE then TSAN won't know about the - // previous read barrier that makes the following access safe. - TSAN_ANNOTATE_BENIGN_RACE(&((StgInd*)bh)->indirectee, "messageBlackHole"); p = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)bh)->indirectee)); info = RELAXED_LOAD(&p->header.info); } while (info == &stg_IND_info); @@ -291,7 +288,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) // makes it into the update remembered set updateRemembSetPushClosure(cap, (StgClosure*)bq->queue); } - RELAXED_STORE(&msg->link, bq->queue); + msg->link = bq->queue; bq->queue = msg; // No barrier is necessary here: we are only exposing the // closure to the GC. See Note [Heap memory barriers] in SMP.h. ===================================== rts/PrimOps.cmm ===================================== @@ -1753,7 +1753,7 @@ loop: qinfo = GET_INFO_ACQUIRE(q); if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1821,7 +1821,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -1923,7 +1923,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2012,7 +2012,7 @@ loop: if (qinfo == stg_IND_info || qinfo == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } @@ -2293,7 +2293,7 @@ loop: //Possibly IND added by removeFromMVarBlockedQueue if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { - q = StgInd_indirectee(q); + q = %acquire StgInd_indirectee(q); goto loop; } ===================================== rts/StableName.c ===================================== @@ -156,11 +156,11 @@ removeIndirections (StgClosure* p) switch (get_itbl(q)->type) { case IND: case IND_STATIC: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); continue; case BLACKHOLE: - p = ((StgInd *)q)->indirectee; + p = ACQUIRE_LOAD(&((StgInd *)q)->indirectee); if (GET_CLOSURE_TAG(p) != 0) { continue; } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -520,8 +520,9 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") (P_ node) { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - node = UNTAG(StgInd_indirectee(node)); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + node = %acquire StgInd_indirectee(node); + node = UNTAG(node); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(node) (node); } @@ -529,8 +530,10 @@ INFO_TABLE(stg_IND,1,0,IND,"IND","IND") /* explicit stack */ { TICK_ENT_DYN_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -540,8 +543,10 @@ INFO_TABLE(stg_IND_STATIC,1,0,IND_STATIC,"IND_STATIC","IND_STATIC") /* explicit stack */ { TICK_ENT_STATIC_IND(); /* tick */ - ACQUIRE_FENCE; - R1 = UNTAG(StgInd_indirectee(R1)); + ACQUIRE_FENCE_ON(R1 + OFFSET_StgHeader_info); + P_ p; + p = %acquire StgInd_indirectee(R1); + R1 = UNTAG(p); TICK_ENT_VIA_NODE(); jump %GET_ENTRY(R1) [R1]; } @@ -564,14 +569,11 @@ INFO_TABLE(stg_BLACKHOLE,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE") TICK_ENT_DYN_IND(); /* tick */ retry: -#if defined(TSAN_ENABLED) - // See Note [ThreadSanitizer and fences] - W_ unused; unused = %acquire GET_INFO(node); -#endif - // Synchronizes with the release-store in updateWithIndirection. + // Synchronizes with the release-store in + // updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. - ACQUIRE_FENCE; - p = %relaxed StgInd_indirectee(node); + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); + p = %acquire StgInd_indirectee(node); if (GETTAG(p) != 0) { return (p); } @@ -656,7 +658,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, WHITEHOLE, "WHITEHOLE", "WHITEHOLE") i = 0; loop: // spin until the WHITEHOLE is updated - info = StgHeader_info(node); + info = %relaxed StgHeader_info(node); if (info == stg_WHITEHOLE_info) { #if defined(PROF_SPIN) W_[whitehole_lockClosure_spin] = @@ -675,6 +677,7 @@ loop: // defined in CMM. goto loop; } + ACQUIRE_FENCE_ON(node + OFFSET_StgHeader_info); jump %ENTRY_CODE(info) (node); #else ccall barf("WHITEHOLE object (%p) entered!", R1) never returns; ===================================== rts/ThreadPaused.c ===================================== @@ -352,7 +352,7 @@ threadPaused(Capability *cap, StgTSO *tso) OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); // The payload of the BLACKHOLE points to the TSO - ((StgInd *)bh)->indirectee = (StgClosure *)tso; + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); // .. and we need a write barrier, since we just mutated the closure: ===================================== rts/Threads.c ===================================== @@ -437,7 +437,7 @@ checkBlockingQueues (Capability *cap, StgTSO *tso) p = UNTAG_CLOSURE(bq->bh); const StgInfoTable *pinfo = ACQUIRE_LOAD(&p->header.info); if (pinfo != &stg_BLACKHOLE_info || - ((StgInd *)p)->indirectee != (StgClosure*)bq) + (RELAXED_LOAD(&((StgInd *)p)->indirectee) != (StgClosure*)bq)) { wakeBlockingQueue(cap,bq); } @@ -468,7 +468,7 @@ updateThunk (Capability *cap, StgTSO *tso, StgClosure *thunk, StgClosure *val) return; } - v = UNTAG_CLOSURE(((StgInd*)thunk)->indirectee); + v = UNTAG_CLOSURE(ACQUIRE_LOAD(&((StgInd*)thunk)->indirectee)); updateWithIndirection(cap, thunk, val); @@ -808,7 +808,7 @@ loop: qinfo = ACQUIRE_LOAD(&q->header.info); if (qinfo == &stg_IND_info || qinfo == &stg_MSG_NULL_info) { - q = (StgMVarTSOQueue*)((StgInd*)q)->indirectee; + q = (StgMVarTSOQueue*) ACQUIRE_LOAD(&((StgInd*)q)->indirectee); goto loop; } ===================================== rts/Updates.cmm ===================================== @@ -59,7 +59,7 @@ INFO_TABLE_RET ( stg_marked_upd_frame, UPDATE_FRAME, ASSERT(HpAlloc == 0); // Note [HpAlloc] // we know the closure is a BLACKHOLE - v = StgInd_indirectee(updatee); + v = %acquire StgInd_indirectee(updatee); if (GETTAG(v) != 0) (likely: False) { // updated by someone else: discard our value and use the ===================================== rts/Updates.h ===================================== @@ -261,6 +261,66 @@ * `tso_1` and other blocked threads may be unblocked more quickly. * * + * Waking up blocking queues + * ------------------------- + * As noted above, when a thread updates a `BLACKHOLE`'d thunk it may find that + * some threads have added themselves to the thunk's blocking queue. Naturally, + * we must ensure that these threads are woken up. However, this gets a bit + * subtle since multiple threads may have raced to enter the thunk. + * + * That is, we may end up in a situation like one of these (TODO audit): + * + * ### Race A + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * finishes evaluation + * thnk.indirectee := result + * handle MSG_BLACKHOLE + * add + * + * ### Race B + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_1->cap + * handle MSG_BLACKHOLE + * add + * finishes evaluation + * thnk.indirectee := result + * + * ### Race C + * + * Thread 0 Thread 1 Thread 2 + * -------------------------- -------------------------- ---------------------- + * enter thnk + * enter thnk + * thnk.indirectee := tso_0 + * thnk.info := BLACKHOLE + * enter, block on thnk + * send MSG_BLACKHOLE to tso_0->cap + * handle MSG_BLACKHOLE + * thnk.indirectee := new BLOCKING_QUEUE + * + * thnk.indirectee := tso_1 + * thnk.info := BLACKHOLE + * + * * Exception handling * ------------------ * When an exception is thrown to a thread which is evaluating a thunk, it is @@ -400,8 +460,8 @@ } \ \ OVERWRITING_CLOSURE(p1); \ - %relaxed StgInd_indirectee(p1) = p2; \ - SET_INFO_RELEASE(p1, stg_BLACKHOLE_info); \ + %release StgInd_indirectee(p1) = p2; \ + %release SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ and_then; ===================================== rts/include/Cmm.h ===================================== @@ -35,6 +35,7 @@ #define CMINUSMINUS 1 #include "ghcconfig.h" +#include "rts/TSANUtils.h" /* ----------------------------------------------------------------------------- Types @@ -311,7 +312,7 @@ #define ENTER(x) ENTER_(return,x) #endif -#define ENTER_R1() ENTER_(RET_R1,R1) +#define ENTER_R1() P_ _r1; _r1 = R1; ENTER_(RET_R1, _r1) #define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] @@ -326,7 +327,7 @@ IND, \ IND_STATIC: \ { \ - x = StgInd_indirectee(x); \ + x = %acquire StgInd_indirectee(x); \ goto again; \ } \ case \ @@ -446,9 +447,17 @@ HP_CHK_P(bytes); \ TICK_ALLOC_RTS(bytes); +// Load a field out of structure with relaxed ordering. +#define RELAXED_LOAD_FIELD(fld, ptr) \ + REP_##fld[(ptr) + OFFSET_##fld] + +// Load a field out of an StgClosure with relaxed ordering. +#define RELAXED_LOAD_CLOSURE_FIELD(fld, ptr) \ + REP_##fld[(ptr) + SIZEOF_StgHeader + OFFSET_##fld] + #define CHECK_GC() \ (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + RELAXED_LOAD_FIELD(generation_n_new_large_words, W_[g0]) >= TO_W_(CLong[large_alloc_lim])) // allocate() allocates from the nursery, so we check to see // whether the nursery is nearly empty in any function that uses @@ -688,9 +697,13 @@ #define RELEASE_FENCE prim %fence_release(); #define ACQUIRE_FENCE prim %fence_acquire(); -// TODO -#if 1 +#if TSAN_ENABLED +// This is may be efficient than a fence but TSAN can reason about it. +#if WORD_SIZE_IN_BITS == 64 #define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire64(x); } +#elif WORD_SIZE_IN_BITS == 32 +#define ACQUIRE_FENCE_ON(x) if (1) { W_ tmp; (tmp) = prim %load_acquire32(x); } +#endif #else #define ACQUIRE_FENCE_ON(x) ACQUIRE_FENCE #endif ===================================== rts/include/rts/TSANUtils.h ===================================== @@ -73,6 +73,7 @@ #endif #endif +#if !defined(CMINUSMINUS) #if defined(TSAN_ENABLED) #if !defined(HAVE_C11_ATOMICS) #error TSAN cannot be enabled without C11 atomics support. @@ -106,3 +107,4 @@ uint32_t ghc_tsan_atomic32_compare_exchange(uint32_t *ptr, uint32_t expected, ui uint16_t ghc_tsan_atomic16_compare_exchange(uint16_t *ptr, uint16_t expected, uint16_t new_value, int success_memorder, int failure_memorder); uint8_t ghc_tsan_atomic8_compare_exchange(uint8_t *ptr, uint8_t expected, uint8_t new_value, int success_memorder, int failure_memorder); +#endif ===================================== rts/include/stg/SMP.h ===================================== @@ -110,6 +110,47 @@ EXTERN_INLINE void busy_wait_nop(void); #endif // !IN_STG_CODE /* + * Note [C11 memory model] + * ~~~~~~~~~~~~~~~~~~~~~~~ + * When it comes to memory, real multiprocessors provide a wide range of + * concurrency semantics due to out-of-order execution and caching. + * To provide consistent reasoning across architectures, GHC relies the C11 + * memory model. Not only does this provide a well-studied, fairly + * easy-to-understand conceptual model, but the C11 memory model gives us + * access to a number of tools which help us verify the compiler (see Note + * [ThreadSanitizer] in rts/include/rts/TSANUtils.h). + * + * Under the C11 model, each processor can be imagined to have a potentially + * out-of-date view onto the system's memory, which can be manipulated with two + * classes of memory operations: + * + * - non-atomic operations (e.g. loads and stores) operate strictly on the + * processor's local view of memory and consequently may not be visible + * from other processors. + * + * - atomic operations (e.g. load, store, fetch-and-{add,subtract,and,or}, + * exchange, and compare-and-swap) parametrized by ordering semantics. + * + * The ordering semantics of an operation (acquire, release, or sequentially + * consistent) will determine the amount of synchronization the operation + * requires. + * + * A processor may synchronize its + * view of memory with that of another processor by performing an atomic + * memory operation. + * + * While non-atomic operations can be thought of as operating on a local + * + * See also: + * + * - The C11 standard, ISO/IEC 14882 2011. + * + * - Boehm, Adve. "Foundations of the C++ Concurrency Memory Model." + * PLDI '08. + * + * - Batty, Owens, Sarkar, Sewall, Weber. "Mathematizing C++ Concurrency." + * POPL '11. + * * Note [Heap memory barriers] * ~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Machines with weak memory ordering semantics have consequences for how @@ -118,31 +159,40 @@ EXTERN_INLINE void busy_wait_nop(void); * stores which formed the new object are visible (e.g. stores are flushed from * cache and the relevant cachelines invalidated in other cores). * - * To ensure this we must use memory barriers. Which barriers are required to - * access a field depends upon the type of the field. In general, fields come - * in three flavours: + * To ensure this we must issue memory barriers when accessing closures and + * their fields. Since reasoning about concurrent memory access with barriers tends to be + * subtle and platform dependent, it is more common to instead write programs + * in terms of an abstract memory model and let the compiler (GHC and the + * system's C compiler) worry about what barriers are needed to realize the + * requested semantics on the target system. GHC relies on the widely used C11 + * memory model for this; see Note [C11 memory model] for a brief introduction. * - * * Mutable GC Pointers (C type StgClosure*, Cmm type StgPtr) - * * Immutable GC Pointers (C type MUT_FIELD StgClosure*, Cmm type StgPtr) - * * Non-pointers (C type StgWord, Cmm type StdWord) + * Also note that the majority of this Note are only concerned with mutation + * by the mutator. The GC is free to change nearly any field (which is + * necessary for a moving GC). Naturally, doing this safely requires care which + * we discuss in the "Barriers during GC" section below. * - * Note that Addr# fields are *not* GC pointers and therefore are classified - * as non-pointers. Responsibility for barriers lies with the party - * dereferencing the pointer. + * Field access + * ------------ + * Which barriers are required to access a field of a closure depends upon the + * identity of the field. In general, fields come in three flavours: * - * Also note that we are only concerned with mutation by the mutator. The GC - * is free to change nearly any field as this is necessary for a moving GC. - * Naturally, doing this safely requires care which we discuss in section - * below. + * * Mutable GC Pointers (C type `StgClosure*`, Cmm type `StgPtr`) + * * Immutable GC Pointers (C type `MUT_FIELD StgClosure*`, Cmm type `StgPtr`) + * * Non-pointers (C type `StgWord`, Cmm type `StgWord`) + * + * Note that Addr# fields are *not* GC pointers and therefore are classified + * as non-pointers. In this case responsibility for barriers lies with the + * party dereferencing the Addr#. * * Immutable pointer fields are those which the mutator cannot change after * an object is made visible on the heap. Most objects' fields are of this * flavour (e.g. all data constructor fields). As these fields are written * precisely once, no write barriers are needed on writes nor reads. This is * safe due to an argument hinging on causality: Consider an immutable field F - * of an object O refers to object O'. Naturally, O' must have been visible to - * the creator of O when O was constructed. Consequently, if O is visible to a - * reader, O' must also be visible. + * of an object O which refers to object O'. Naturally, O' must have been + * visible to the creator of O when O was constructed. Consequently, if O is + * visible to a reader, O' must also be visible to the same reader. * * Mutable pointer fields are those which can be modified by the mutator. These * require a bit more care as they may break the causality argument given @@ -151,6 +201,10 @@ EXTERN_INLINE void busy_wait_nop(void); * into F. Without explicit synchronization O' may not be visible to another * thread attempting to dereference F. * + * To ensure the visibility of the referent, writing to a mutable pointer field + * must be done via a release-store. Conversely, reading from such a field is + * done via an acquire-load. + * * Mutable fields include: * * - StgMutVar: var @@ -163,64 +217,102 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgMutArrPtrs: payload * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below - * - * Writing to a mutable pointer field must be done via a release-store. - * Reading from such a field is done via an acquire-load. + * - StgInd: indirectee * * Finally, non-pointer fields can be safely mutated without barriers as - * they do not refer to other memory. Technically, concurrent accesses to - * non-pointer fields still do need to be atomic in many cases to avoid torn - * accesses. However, this is something that we generally avoid by locking - * closures prior to mutating non-pointer fields (see Locking closures below). - * - * Note that MUT_VARs offer both synchronized and unsynchronized primops. - * Consequently, in these cases there is a burden on the user to ensure that - * synchronization is provided where necessary. + * they do not refer to other memory locations. Technically, concurrent + * accesses to non-pointer fields still do need to be atomic in many cases to + * avoid torn accesses. However, this is something that we generally avoid by + * locking closures prior to mutating non-pointer fields (see Locking closures + * below). * * Locking closures * ---------------- * Several primops temporarily turn closures into WHITEHOLEs to ensure that * they have exclusive access (see SMPClosureOps.h:reallyLockClosure). + * These include, + * + * - takeMVar#, tryTakeMVar# + * - putMVar#, tryPutMVar# + * - readMVar#, tryReadMVar# + * - readIOPort# + * - writeIOPort# + * - addCFinalizerToWeak# + * - finalizeWeak# + * - deRefWeak# + * * Locking is done via an atomic exchange operation on the closure's info table * pointer with sequential consistency (although only acquire ordering is - * needed). This acquire ensures that we synchronize with any previous thread - * that had locked the closure. Consequently, it is important that we take great - * care in examining the mutable fields of a lockable closure prior to having - * locked it. - * - * Naturally, unlocking is done via a release-store to restore the closure's - * original info table pointer. + * needed). Similarly, unlocking is also done with an atomic exchange to + * restore the closure's original info table pointer (although + * this time only the release ordering is needed). This ensures + * that we synchronize with any previous thread that had locked the closure. * * Thunks * ------ * As noted above, thunks are a rather special (yet quite common) case. In - * particular, they have the unique property of being updatable, transforming - * from a thunk to an indirection. This transformation requires its own - * synchronization protocol. In particular, we must ensure that a reader - * examining a thunk being updated can see the indirectee. Consequently, a - * thunk update (see rts/Updates.h) does the following: + * particular, they have the unique property of being updatable (that is, can + * be transformed from a thunk into an indirection after evaluation). This + * transformation requires its own synchronization protocol to mediate the + * interaction between the updater and the reader. In particular, we + * must ensure that a reader examining a thunk being updated by another core + * can see the indirectee. Consequently, a thunk update (see rts/Updates.h) + * does the following: + * + * U1. use a release-store to place the new indirectee into the thunk's + * indirectee field * - * 1. Use a relaxed-store to place the new indirectee into the thunk's - * indirectee field - * 2. use a release-store to set the info table to stg_BLACKHOLE (which - * represents an indirection) + * U2. use a release-store to set the info table to stg_BLACKHOLE (which + * represents an indirection) * * Blackholing a thunk (either eagerly, by GHC.StgToCmm.Bind.emitBlackHoleCode, * or lazily, by ThreadPaused.c:threadPaused) is done similarly. * - * Conversely, indirection entry (see the entry code of stg_BLACKHOLE, stg_IND, - * and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the following: - * - * 1. We jump into the entry code for, e.g., stg_BLACKHOLE; this of course - * implies that we have already read the thunk's info table pointer, which - * is done with a relaxed load. - * 2. use an acquire-fence to ensure that our view on the thunk is - * up-to-date. This synchronizes with step (2) in the update - * procedure. - * 3. relaxed-load the indirectee. Since thunks are updated at most - * once we know that the fence in the last step has given us - * an up-to-date view of the indirectee closure. - * 4. enter the indirectee (or block if the indirectee is a TSO) + * Conversely, entering an indirection (see the entry code of stg_BLACKHOLE, + * stg_IND, and stg_IND_STATIC in rts/StgMiscClosure.cmm) does the + * following: + * + * E1. jump into the entry code of the indirection (e.g. stg_BLACKHOLE); + * this of course implies that we have already read the thunk's info table + * pointer, which is done with a relaxed load. + * + * E2. acquire-fence + * + * E3. acquire-load the indirectee. Since thunks are updated at most + * once we know that the fence in the last step has given us + * an up-to-date view of the indirectee closure. + * + * E4. enter the indirectee (or block if the indirectee is a TSO) + * + * The release/acquire pair (U2)/(E2) is somewhat surprising but is necessary as + * the C11 memory model does not guarantee that the store (U1) is visible to + * (E3) despite (U1) preceding (U2) in program-order (due to the relaxed + * ordering of (E3)). This is demonstrated by the following CppMem model: + * + * int main() { + * atomic_int x = 0; // info table pointer + * atomic_int y = 0; // indirectee + * {{{ + * { // blackhole update + * y.store(1, memory_order_release); // U1 + * x.store(2, memory_order_release); // U2 + * } + * ||| + * { // blackhole entry + * r1=x.load(memory_order_relaxed).readsvalue(2); // E1 + * //fence(memory_order_acquire); // E2 + * r2=y.load(memory_order_acquire); // E3 + * } + * }}}; + * return 0; + * } + * + * Under the C11 memory model this program admits an execution where the + * indirectee `r2=0`. + * + * Of course, this could also be addressed by strengthing the ordering of (E1) + * to acquire, but this would incur a significant cost on every closure entry + * (including non-blackholes). * * Other closures * -------------- @@ -328,6 +420,12 @@ EXTERN_INLINE void busy_wait_nop(void); * The work-stealing queue (WSDeque) also requires barriers; these are * documented in WSDeque.c. * + * Verifying memory ordering + * ------------------------- + * To verify that GHC's RTS and the code produced by the compiler are free of + * data races we employ ThreadSaniziter. See Note [ThreadSanitizer] in TSANUtils.h + * for details on this facility. + * */ /* ---------------------------------------------------------------------------- ===================================== rts/sm/Evac.c ===================================== @@ -1542,7 +1542,7 @@ selector_loop: bale_out: // We didn't manage to evaluate this thunk; restore the old info // pointer. But don't forget: we still need to evacuate the thunk itself. - SET_INFO((StgClosure *)p, (const StgInfoTable *)info_ptr); + SET_INFO_RELAXED((StgClosure *)p, (const StgInfoTable *)info_ptr); // THREADED_RTS: we just unlocked the thunk, so another thread // might get in and update it. copy() will lock it again and // check whether it was updated in the meantime. ===================================== rts/sm/NonMovingMark.c ===================================== @@ -688,8 +688,9 @@ void updateRemembSetPushThunkEager(Capability *cap, case IND: { StgInd *ind = (StgInd *) thunk; - if (check_in_nonmoving_heap(ind->indirectee)) { - push_closure(queue, ind->indirectee, NULL); + StgClosure *indirectee = ACQUIRE_LOAD(&ind->indirectee); + if (check_in_nonmoving_heap(indirectee)) { + push_closure(queue, indirectee, NULL); } break; } @@ -1587,7 +1588,7 @@ mark_closure (MarkQueue *queue, const StgClosure *p0, StgClosure **origin) // Synchronizes with the release-store in updateWithIndirection. // See Note [Heap memory barriers] in SMP.h. StgInd *ind = (StgInd *) p; - ACQUIRE_FENCE(); + ACQUIRE_FENCE_ON(&p->header.info); StgClosure *indirectee = RELAXED_LOAD(&ind->indirectee); markQueuePushClosure(queue, indirectee, &ind->indirectee); if (GET_CLOSURE_TAG(indirectee) == 0 || origin == NULL) { ===================================== rts/sm/Storage.c ===================================== @@ -596,8 +596,6 @@ lockCAF (StgRegTable *reg, StgIndStatic *caf) bh->indirectee = (StgClosure *)cap->r.rCurrentTSO; SET_HDR(bh, &stg_CAF_BLACKHOLE_info, caf->header.prof.ccs); - // RELEASE ordering to ensure that above writes are visible before we - // introduce reference as CAF indirectee. RELEASE_STORE(&caf->indirectee, (StgClosure *) bh); SET_INFO_RELEASE((StgClosure*)caf, &stg_IND_STATIC_info); ===================================== utils/genapply/Main.hs ===================================== @@ -783,7 +783,11 @@ genApply regstatus args = text "case IND,", text " IND_STATIC: {", nest 4 (vcat [ - text "R1 = StgInd_indirectee(R1);", + -- N.B. annoyingly the %acquire syntax must place its result in a local register + -- as it is a Cmm prim call node. + text "P_ p;", + text "p = %acquire StgInd_indirectee(R1);", + text "R1 = p;", -- An indirection node might contain a tagged pointer text "goto again;" ]), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14b1038ec9a94c46107cec49cbeb18fc3ebe037e -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14b1038ec9a94c46107cec49cbeb18fc3ebe037e 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 Dec 15 21:33:28 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 15 Dec 2023 16:33:28 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 18 commits: Fix thunk update ordering Message-ID: <657cc6283bd41_e7a73118f3d681739f9@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 14b1038e by Ben Gamari at 2023-12-15T16:16:14-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. - - - - - caad5ba0 by Ben Gamari at 2023-12-15T16:33:20-05:00 rts: Fix data race in threadPaused This only affects an assertion in the debug RTS and only needs relaxed ordering. - - - - - e2cb4c18 by Ben Gamari at 2023-12-15T16:33:20-05:00 cmm: Introduce MO_RelaxedRead In hand-written Cmm it can sometimes be necessary to atomically load from memory deep within an expression (e.g. see the `CHECK_GC` macro). This MachOp provides a convenient way to do so without breaking the expression into multiple statements. - - - - - 5b631155 by Ben Gamari at 2023-12-15T16:33:20-05:00 codeGen: Use relaxed accesses in ticky bumping - - - - - 94a3885d by Ben Gamari at 2023-12-15T16:33:20-05:00 rts: Fix data race in Interpreter's preemption check - - - - - f40022d4 by Ben Gamari at 2023-12-15T16:33:20-05:00 rts: Fix data race in threadStatus# - - - - - 7f3680a0 by Ben Gamari at 2023-12-15T16:33:20-05:00 base: use atomic write when updating timer manager - - - - - 3ef7d2b1 by Ben Gamari at 2023-12-15T16:33:21-05:00 Use relaxed atomics to manipulate TSO status fields - - - - - 9db191b5 by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Add necessary barriers when manipulating TSO owner - - - - - 2e248f95 by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Use `switch` to branch on why_blocked This is a semantics-preserving refactoring. - - - - - df15432e by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Fix synchronization on thread blocking state - - - - - ea3f34cb by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 69047711 by Ben Gamari at 2023-12-15T16:33:21-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 32a4b9a7 by Ben Gamari at 2023-12-15T16:33:21-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 61a246c9 by Ben Gamari at 2023-12-15T16:33:21-05:00 rts/Messages: Fix data race - - - - - 1a4e7aef by Ben Gamari at 2023-12-15T16:33:21-05:00 rts/Prof: Fix data race - - - - - f1f501f3 by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - bf2b3041 by Ben Gamari at 2023-12-15T16:33:21-05:00 rts: Fix data races in profiling timer - - - - - 30 changed files: - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/ThreadSanitizer.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Wasm/FromCmm.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Ticky.hs - compiler/GHC/StgToCmm/Utils.hs - libraries/base/src/GHC/Event/Thread.hs - rts/Apply.cmm - rts/Compact.cmm - rts/Exception.cmm - rts/Heap.c - rts/HeapStackCheck.cmm - rts/Interpreter.c - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StableName.c - rts/StgMiscClosures.cmm - rts/StgStartup.cmm The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5d0321143668d95bd74549c541bcddb32dcbc13...bf2b3041accc5df3f3c5a980a1f8e4e10a34a2e1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5d0321143668d95bd74549c541bcddb32dcbc13...bf2b3041accc5df3f3c5a980a1f8e4e10a34a2e1 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 Dec 16 01:25:47 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Fri, 15 Dec 2023 20:25:47 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 8 commits: rts: Fix synchronization on thread blocking state Message-ID: <657cfc9b9137c_e7a731742515017966@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 3f207212 by Ben Gamari at 2023-12-15T20:24:40-05:00 rts: Fix synchronization on thread blocking state We now use a release barrier whenever we update a thread's blocking state. This required widening StgTSO.why_blocked as AArch64 does not support atomic writes on 16-bit values. - - - - - 03f58de6 by Ben Gamari at 2023-12-15T20:25:21-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - 23e628ff by Ben Gamari at 2023-12-15T20:25:21-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - cd53715b by Ben Gamari at 2023-12-15T20:25:21-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 4ce8a431 by Ben Gamari at 2023-12-15T20:25:22-05:00 rts/Messages: Fix data race - - - - - ae21b34e by Ben Gamari at 2023-12-15T20:25:22-05:00 rts/Prof: Fix data race - - - - - fafa9b34 by Ben Gamari at 2023-12-15T20:25:22-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - bc8eba8e by Ben Gamari at 2023-12-15T20:25:22-05:00 rts: Fix data races in profiling timer - - - - - 22 changed files: - compiler/GHC/Cmm/Info.hs - rts/Exception.cmm - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureMacros.h - rts/include/rts/storage/TSO.h - rts/include/stg/SMP.h - rts/posix/Select.c - rts/sm/Compact.c - rts/sm/GC.c - rts/sm/GCAux.c - rts/sm/NonMovingMark.c - rts/sm/Scav.c - rts/sm/Storage.c - rts/win32/AsyncMIO.c Changes: ===================================== compiler/GHC/Cmm/Info.hs ===================================== @@ -449,7 +449,7 @@ wordAligned platform align_check e -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e = - cmmLoadBWord platform (wordAligned platform align_check e) + CmmMachOp (MO_RelaxedRead (wordWidth platform)) [wordAligned platform align_check e] -- | Takes an info pointer (the first word of a closure) and returns its entry -- code ===================================== rts/Exception.cmm ===================================== @@ -351,9 +351,9 @@ stg_killThreadzh (P_ target, P_ exception) if (msg == NULL) { return (); } else { - StgTSO_why_blocked(CurrentTSO) = BlockedOnMsgThrowTo; updateRemembSetPushPtr(StgTSO_block_info(CurrentTSO)); StgTSO_block_info(CurrentTSO) = msg; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMsgThrowTo; // we must block, and unlock the message before returning jump stg_block_throwto (target, exception); } ===================================== rts/Messages.c ===================================== @@ -205,7 +205,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgTSO *owner = (StgTSO*)p; #if defined(THREADED_RTS) - if (owner->cap != cap) { + if (RELAXED_LOAD(&owner->cap) != cap) { sendMessage(cap, owner->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); @@ -275,7 +275,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) ASSERT(owner != END_TSO_QUEUE); #if defined(THREADED_RTS) - if (owner->cap != cap) { + if (RELAXED_LOAD(&owner->cap) != cap) { sendMessage(cap, owner->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); ===================================== rts/PrimOps.cmm ===================================== @@ -827,7 +827,9 @@ stg_atomicModifyMutVarzuzh ( gcptr mv, gcptr f ) StgMutVar_var(mv) = z; #endif - if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) { + W_ info; + info = %relaxed GET_INFO(mv); + if (info == stg_MUT_VAR_CLEAN_info) { ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr", x "ptr"); } @@ -1715,21 +1717,17 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // Write barrier before we make the new MVAR_TSO_QUEUE - // visible to other cores. - // See Note [Heap memory barriers] - RELEASE_FENCE; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; + %release StgMVar_head(mvar) = q; } else { - StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; + %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); } StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; StgMVar_tail(mvar) = q; jump stg_block_takemvar(mvar); @@ -1884,19 +1882,17 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; + %release StgMVar_head(mvar) = q; } else { - StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; + %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); } StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; StgMVar_tail(mvar) = q; jump stg_block_putmvar(mvar,val); @@ -2033,11 +2029,11 @@ loop: } } - ASSERT(StgTSO_block_info(tso) == mvar); // save why_blocked here, because waking up the thread destroys // this information W_ why_blocked; - why_blocked = TO_W_(StgTSO_why_blocked(tso)); + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO: Missing barrier + ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the takeMVar W_ stack; @@ -2093,13 +2089,11 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; + %release StgMVar_head(mvar) = q; StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; - StgMVar_head(mvar) = q; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = q; @@ -2226,17 +2220,16 @@ stg_readIOPortzh ( P_ ioport /* :: IOPort a */ ) StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; - StgMVar_head(ioport) = q; + %release StgMVar_head(ioport) = q; StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = ioport; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + + // See Note [Heap memory barriers] + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; //Unlocks the closure as well jump stg_block_readmvar(ioport); - } //This way we can check of there has been a read already. @@ -2314,11 +2307,11 @@ loop: // next element in the waiting list here, as there can only ever // be one thread blocked on a port. - ASSERT(StgTSO_block_info(tso) == ioport); // save why_blocked here, because waking up the thread destroys // this information W_ why_blocked; - why_blocked = TO_W_(StgTSO_why_blocked(tso)); + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO Missing acquire + ASSERT(StgTSO_block_info(tso) == ioport); // actually perform the takeMVar W_ stack; @@ -2560,8 +2553,8 @@ stg_waitReadzh ( W_ fd ) #else ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; StgTSO_block_info(CurrentTSO) = fd; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; // No locking - we're not going to use this interface in the // threaded RTS anyway. ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); @@ -2576,8 +2569,8 @@ stg_waitWritezh ( W_ fd ) #else ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; StgTSO_block_info(CurrentTSO) = fd; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; // No locking - we're not going to use this interface in the // threaded RTS anyway. ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); @@ -2599,7 +2592,6 @@ stg_delayzh ( W_ us_delay ) #else ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16; #if defined(mingw32_HOST_OS) @@ -2616,12 +2608,13 @@ stg_delayzh ( W_ us_delay ) * simplifies matters, so change the status to OnDoProc put the * delayed thread on the blocked_queue. */ - StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async_void(); #else + %relaxed StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16; (target) = ccall getDelayTarget(us_delay); StgTSO_block_info(CurrentTSO) = target; @@ -2643,9 +2636,6 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) ccall barf("asyncRead# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; - /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncReadzh"); @@ -2654,6 +2644,10 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif @@ -2668,9 +2662,6 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) ccall barf("asyncWrite# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; - ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncWritezh"); (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr"); @@ -2679,6 +2670,10 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif @@ -2693,9 +2688,6 @@ stg_asyncDoProczh ( W_ proc, W_ param ) ccall barf("asyncDoProc# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; - /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncDoProczh"); @@ -2704,6 +2696,10 @@ stg_asyncDoProczh ( W_ proc, W_ param ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif ===================================== rts/Proftimer.c ===================================== @@ -101,7 +101,7 @@ requestHeapCensus( void ){ void initProfTimer( void ) { - performHeapProfile = false; + RELAXED_STORE_ALWAYS(&performHeapProfile, false); ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; @@ -124,7 +124,8 @@ handleProfTick(void) uint32_t n; for (n=0; n < getNumCapabilities(); n++) { Capability *cap = getCapability(n); - cap->r.rCCCS->time_ticks++; + CostCentreStack *ccs = RELAXED_LOAD(&cap->r.rCCCS); + ccs->time_ticks++; traceProfSampleCostCentre(cap, cap->r.rCCCS, total_ticks); } } @@ -135,7 +136,7 @@ handleProfTick(void) ticks_to_ticky_sample--; if (ticks_to_ticky_sample <= 0) { ticks_to_ticky_sample = RtsFlags.ProfFlags.heapProfileIntervalTicks; - performTickySample = true; + RELAXED_STORE_ALWAYS(&performTickySample, true); } } #endif @@ -144,7 +145,7 @@ handleProfTick(void) ticks_to_heap_profile--; if (ticks_to_heap_profile <= 0) { ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; - performHeapProfile = true; + RELAXED_STORE_ALWAYS(&performHeapProfile, true); } } } ===================================== rts/RaiseAsync.c ===================================== @@ -266,7 +266,7 @@ check_target: return THROWTO_BLOCKED; } - status = target->why_blocked; + status = ACQUIRE_LOAD(&target->why_blocked); switch (status) { case NotBlocked: @@ -728,7 +728,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) } done: - tso->why_blocked = NotBlocked; + RELAXED_STORE(&tso->why_blocked, NotBlocked); appendToRunQueue(cap, tso); } ===================================== rts/STM.c ===================================== @@ -187,7 +187,7 @@ static StgClosure *lock_tvar(Capability *cap STG_UNUSED, StgTVar *s STG_UNUSED) { StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); return result; } @@ -198,7 +198,7 @@ static void unlock_tvar(Capability *cap, StgBool force_update) { TRACE("%p : unlock_tvar(%p)", trec, s); if (force_update) { - StgClosure *old_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *old_value = ACQUIRE_LOAD(&s->current_value); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, old_value); } @@ -210,7 +210,7 @@ static StgBool cond_lock_tvar(Capability *cap STG_UNUSED, StgClosure *expected) { StgClosure *result; TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); TRACE("%p : %s", trec, (result == expected) ? "success" : "failure"); return (result == expected); } @@ -231,7 +231,7 @@ static void lock_stm(StgTRecHeader *trec) { static void unlock_stm(StgTRecHeader *trec STG_UNUSED) { TRACE("%p : unlock_stm()", trec); ASSERT(smp_locked == trec); - SEQ_CST_STORE(&smp_locked, 0); + RELEASE_STORE(&smp_locked, 0); } static StgClosure *lock_tvar(Capability *cap STG_UNUSED, @@ -240,7 +240,7 @@ static StgClosure *lock_tvar(Capability *cap STG_UNUSED, StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); ASSERT(smp_locked == trec); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); return result; } @@ -252,7 +252,7 @@ static void *unlock_tvar(Capability *cap, TRACE("%p : unlock_tvar(%p, %p)", trec, s, c); ASSERT(smp_locked == trec); if (force_update) { - StgClosure *old_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *old_value = ACQUIRE_LOAD(&s->current_value); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, old_value); } @@ -265,7 +265,7 @@ static StgBool cond_lock_tvar(Capability *cap STG_UNUSED, StgClosure *result; TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected); ASSERT(smp_locked == trec); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); TRACE("%p : %d", result ? "success" : "failure"); return (result == expected); } @@ -291,9 +291,11 @@ static StgClosure *lock_tvar(Capability *cap, StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); do { + const StgInfoTable *info; do { - result = SEQ_CST_LOAD(&s->current_value); - } while (GET_INFO(UNTAG_CLOSURE(result)) == &stg_TREC_HEADER_info); + result = ACQUIRE_LOAD(&s->current_value); + info = GET_INFO(UNTAG_CLOSURE(result)); + } while (info == &stg_TREC_HEADER_info); } while (cas((void *) &s->current_value, (StgWord)result, (StgWord)trec) != (StgWord)result); @@ -311,7 +313,7 @@ static void unlock_tvar(Capability *cap, StgClosure *c, StgBool force_update STG_UNUSED) { TRACE("%p : unlock_tvar(%p, %p)", trec, s, c); - ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); + ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, (StgClosure *) trec); } @@ -340,8 +342,8 @@ static StgBool cond_lock_tvar(Capability *cap, static void park_tso(StgTSO *tso) { ASSERT(tso -> why_blocked == NotBlocked); - tso -> why_blocked = BlockedOnSTM; tso -> block_info.closure = (StgClosure *) END_TSO_QUEUE; + RELEASE_STORE(&tso -> why_blocked, BlockedOnSTM); TRACE("park_tso on tso=%p", tso); } @@ -375,7 +377,7 @@ static void unpark_waiters_on(Capability *cap, StgTVar *s) { StgTVarWatchQueue *trail; TRACE("unpark_waiters_on tvar=%p", s); // unblock TSOs in reverse order, to be a bit fairer (#2319) - for (q = SEQ_CST_LOAD(&s->first_watch_queue_entry), trail = q; + for (q = ACQUIRE_LOAD(&s->first_watch_queue_entry), trail = q; q != END_STM_WATCH_QUEUE; q = q -> next_queue_entry) { trail = q; @@ -532,16 +534,16 @@ static void build_watch_queue_entries_for_trec(Capability *cap, StgTVarWatchQueue *fq; s = e -> tvar; TRACE("%p : adding tso=%p to watch queue for tvar=%p", trec, tso, s); - ACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); - NACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == e -> expected_value); - fq = SEQ_CST_LOAD(&s->first_watch_queue_entry); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); + NACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == e -> expected_value); + fq = ACQUIRE_LOAD(&s->first_watch_queue_entry); q = alloc_stg_tvar_watch_queue(cap, (StgClosure*) tso); q -> next_queue_entry = fq; q -> prev_queue_entry = END_STM_WATCH_QUEUE; if (fq != END_STM_WATCH_QUEUE) { fq -> prev_queue_entry = q; } - SEQ_CST_STORE(&s->first_watch_queue_entry, q); + RELEASE_STORE(&s->first_watch_queue_entry, q); e -> new_value = (StgClosure *) q; dirty_TVAR(cap, s, (StgClosure *) fq); // we modified first_watch_queue_entry }); @@ -569,7 +571,7 @@ static void remove_watch_queue_entries_for_trec(Capability *cap, trec, q -> closure, s); - ACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); nq = q -> next_queue_entry; pq = q -> prev_queue_entry; if (nq != END_STM_WATCH_QUEUE) { @@ -578,8 +580,8 @@ static void remove_watch_queue_entries_for_trec(Capability *cap, if (pq != END_STM_WATCH_QUEUE) { pq -> next_queue_entry = nq; } else { - ASSERT(SEQ_CST_LOAD(&s->first_watch_queue_entry) == q); - SEQ_CST_STORE(&s->first_watch_queue_entry, nq); + ASSERT(ACQUIRE_LOAD(&s->first_watch_queue_entry) == q); + RELEASE_STORE(&s->first_watch_queue_entry, nq); dirty_TVAR(cap, s, (StgClosure *) q); // we modified first_watch_queue_entry } free_stg_tvar_watch_queue(cap, q); @@ -727,7 +729,7 @@ static StgBool entry_is_read_only(TRecEntry *e) { static StgBool tvar_is_locked(StgTVar *s, StgTRecHeader *h) { StgClosure *c; StgBool result; - c = SEQ_CST_LOAD(&s->current_value); + c = ACQUIRE_LOAD(&s->current_value); result = (c == (StgClosure *) h); return result; } @@ -803,13 +805,13 @@ static StgBool validate_and_acquire_ownership (Capability *cap, // The memory ordering here must ensure that we have two distinct // reads to current_value, with the read from num_updates between // them. - if (SEQ_CST_LOAD(&s->current_value) != e -> expected_value) { + if (ACQUIRE_LOAD(&s->current_value) != e -> expected_value) { TRACE("%p : doesn't match", trec); result = false; BREAK_FOR_EACH; } e->num_updates = SEQ_CST_LOAD(&s->num_updates); - if (SEQ_CST_LOAD(&s->current_value) != e -> expected_value) { + if (ACQUIRE_LOAD(&s->current_value) != e -> expected_value) { TRACE("%p : doesn't match (race)", trec); result = false; BREAK_FOR_EACH; @@ -852,7 +854,7 @@ static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) { // We must first load current_value then num_updates; this is inverse of // the order of the stores in stmCommitTransaction. - StgClosure *current_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *current_value = ACQUIRE_LOAD(&s->current_value); StgInt num_updates = SEQ_CST_LOAD(&s->num_updates); // Note we need both checks and in this order as the TVar could be @@ -1186,7 +1188,7 @@ StgBool stmCommitNestedTransaction(Capability *cap, StgTRecHeader *trec) { unlock_tvar(cap, trec, s, e -> expected_value, false); } merge_update_into(cap, et, s, e -> expected_value, e -> new_value); - ACQ_ASSERT(s -> current_value != (StgClosure *)trec); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) != (StgClosure *)trec); }); } else { revert_ownership(cap, trec, false); ===================================== rts/Schedule.c ===================================== @@ -512,7 +512,8 @@ run_thread: #endif if (ret == ThreadBlocked) { - if (t->why_blocked == BlockedOnBlackHole) { + uint16_t why_blocked = ACQUIRE_LOAD(&t->why_blocked); + if (why_blocked == BlockedOnBlackHole) { StgTSO *owner = blackHoleOwner(t->block_info.bh->bh); traceEventStopThread(cap, t, t->why_blocked + 6, owner != NULL ? owner->id : 0); @@ -1385,7 +1386,7 @@ scheduleNeedHeapProfile( bool ready_to_gc ) { // When we have +RTS -i0 and we're heap profiling, do a census at // every GC. This lets us get repeatable runs for debugging. - if (performHeapProfile || + if (RELAXED_LOAD(&performHeapProfile) || (RtsFlags.ProfFlags.heapProfileInterval==0 && RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) { return true; @@ -1946,7 +1947,7 @@ delete_threads_and_gc: // The heap census itself is done during GarbageCollect(). if (heap_census) { - performHeapProfile = false; + RELAXED_STORE(&performHeapProfile, false); } #if defined(THREADED_RTS) ===================================== rts/StgMiscClosures.cmm ===================================== @@ -606,8 +606,8 @@ retry: if (r == 0) { goto retry; } else { - StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16; StgTSO_block_info(CurrentTSO) = msg; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16; jump stg_block_blackhole(node); } } ===================================== rts/Threads.c ===================================== @@ -94,8 +94,8 @@ createThread(Capability *cap, W_ size) // Always start with the compiled code evaluator tso->what_next = ThreadRunGHC; - tso->why_blocked = NotBlocked; tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; + tso->why_blocked = NotBlocked; tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE; tso->bq = (StgBlockingQueue *)END_TSO_QUEUE; tso->flags = 0; @@ -286,7 +286,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) } #endif - switch (tso->why_blocked) + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: @@ -826,10 +826,11 @@ loop: } } - ASSERT(tso->block_info.closure == (StgClosure*)mvar); // save why_blocked here, because waking up the thread destroys // this information - StgWord why_blocked = RELAXED_LOAD(&tso->why_blocked); + StgWord why_blocked = ACQUIRE_LOAD(&tso->why_blocked); + ASSERT(why_blocked == BlockedOnMVarRead || why_blocked == BlockedOnMVar); + ASSERT(tso->block_info.closure == (StgClosure*)mvar); // actually perform the takeMVar StgStack* stack = tso->stackobj; @@ -903,7 +904,7 @@ StgMutArrPtrs *listThreads(Capability *cap) void printThreadBlockage(StgTSO *tso) { - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { #if defined(mingw32_HOST_OS) case BlockedOnDoProc: debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID); ===================================== rts/TraverseHeap.c ===================================== @@ -1239,7 +1239,7 @@ inner_loop: traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, sep, child_data); traversePushClosure(ts, (StgClosure *) tso->bq, c, sep, child_data); traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data); - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -184,7 +184,7 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con) // Use when changing a closure from one kind to another #define OVERWRITE_INFO(c, new_info) \ OVERWRITING_CLOSURE((StgClosure *)(c)); \ - SET_INFO((StgClosure *)(c), (new_info)); \ + SET_INFO_RELAXED((StgClosure *)(c), (new_info)); \ LDV_RECORD_CREATE(c); /* ----------------------------------------------------------------------------- ===================================== rts/include/rts/storage/TSO.h ===================================== @@ -126,9 +126,14 @@ typedef struct StgTSO_ { */ StgWord16 what_next; // Values defined in Constants.h - StgWord16 why_blocked; // Values defined in Constants.h StgWord32 flags; // Values defined in Constants.h - StgTSOBlockInfo block_info; + + /* + * N.B. why_blocked only has a handful of values but must be atomically + * updated; the smallest width which AArch64 supports for is 32-bits. + */ + StgWord32 why_blocked; // Values defined in Constants.h + StgTSOBlockInfo block_info; // Barrier provided by why_blocked StgThreadID id; StgWord32 saved_errno; StgWord32 dirty; /* non-zero => dirty */ ===================================== rts/include/stg/SMP.h ===================================== @@ -218,6 +218,7 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below * - StgInd: indirectee + * - StgTSO: block_info * * Finally, non-pointer fields can be safely mutated without barriers as * they do not refer to other memory locations. Technically, concurrent @@ -346,6 +347,14 @@ EXTERN_INLINE void busy_wait_nop(void); * the capability-local mut_list. Consequently this does not require any memory * barrier. * + * Barriers in thread blocking + * --------------------------- + * When a thread blocks (e.g. on an MVar) it will typically allocate a heap object + * to record its blocked-ness (e.g. a StgMVarTSOQueue), expose this via + * StgTSO.block_info, and update StgTSO.why_blocked to record the reason for + * its blocking. The visibility of the block_info is guaranteed by the ordering + * of the why_blocked update. + * * Barriers in thread migration * ---------------------------- * When a thread is migrated from one capability to another we must take care ===================================== rts/posix/Select.c ===================================== @@ -105,7 +105,7 @@ static bool wakeUpSleepingThreads (Capability *cap, LowResTime now) break; } iomgr->sleeping_queue = tso->_link; - tso->why_blocked = NotBlocked; + RELAXED_STORE(&tso->why_blocked, NotBlocked); tso->_link = END_TSO_QUEUE; IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %" FMT_StgThreadID "\n", tso->id)); @@ -268,7 +268,7 @@ awaitEvent(Capability *cap, bool wait) * So the (int) cast should be removed across the code base once * GHC requires a version of FreeBSD that has that change in it. */ - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnRead: { int fd = tso->block_info.fd; ===================================== rts/sm/Compact.c ===================================== @@ -463,7 +463,7 @@ thread_TSO (StgTSO *tso) thread_(&tso->_link); thread_(&tso->global_link); - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/GC.c ===================================== @@ -340,8 +340,8 @@ GarbageCollect (struct GcConfig config, // attribute any costs to CCS_GC #if defined(PROFILING) for (n = 0; n < getNumCapabilities(); n++) { - save_CCS[n] = getCapability(n)->r.rCCCS; - getCapability(n)->r.rCCCS = CCS_GC; + save_CCS[n] = RELAXED_LOAD(&getCapability(n)->r.rCCCS); + RELAXED_STORE(&getCapability(n)->r.rCCCS, CCS_GC); } #endif @@ -979,9 +979,9 @@ GarbageCollect (struct GcConfig config, // Post ticky counter sample. // We do this at the end of execution since tickers are registered in the // course of program execution. - if (performTickySample) { + if (RELAXED_LOAD(&performTickySample)) { emitTickyCounterSamples(); - performTickySample = false; + RELAXED_STORE(&performTickySample, false); } #endif ===================================== rts/sm/GCAux.c ===================================== @@ -91,7 +91,7 @@ isAlive(StgClosure *p) return TAG_CLOSURE(tag,(StgClosure*)UN_FORWARDING_PTR(info)); } - info = ACQUIRE_LOAD(&q->header.info); + ACQUIRE_FENCE_ON(&q->header.info); info = INFO_PTR_TO_STRUCT(info); switch (info->type) { ===================================== rts/sm/NonMovingMark.c ===================================== @@ -1052,7 +1052,7 @@ trace_tso (MarkQueue *queue, StgTSO *tso) if (tso->label != NULL) { markQueuePushClosure_(queue, (StgClosure *) tso->label); } - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/Scav.c ===================================== @@ -137,7 +137,7 @@ scavengeTSO (StgTSO *tso) evacuate((StgClosure **)&tso->label); } - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/Storage.c ===================================== @@ -1440,7 +1440,7 @@ dirty_MUT_VAR(StgRegTable *reg, StgMutVar *mvar, StgClosure *old) Capability *cap = regTableToCapability(reg); // No barrier required here as no other heap object fields are read. See // Note [Heap memory barriers] in SMP.h. - SET_INFO((StgClosure*) mvar, &stg_MUT_VAR_DIRTY_info); + SET_INFO_RELAXED((StgClosure*) mvar, &stg_MUT_VAR_DIRTY_info); recordClosureMutated(cap, (StgClosure *) mvar); IF_NONMOVING_WRITE_BARRIER_ENABLED { // See Note [Dirty flags in the non-moving collector] in NonMoving.c @@ -1462,7 +1462,7 @@ dirty_TVAR(Capability *cap, StgTVar *p, // No barrier required here as no other heap object fields are read. See // Note [Heap memory barriers] in SMP.h. if (RELAXED_LOAD(&p->header.info) == &stg_TVAR_CLEAN_info) { - SET_INFO((StgClosure*) p, &stg_TVAR_DIRTY_info); + SET_INFO_RELAXED((StgClosure*) p, &stg_TVAR_DIRTY_info); recordClosureMutated(cap,(StgClosure*)p); IF_NONMOVING_WRITE_BARRIER_ENABLED { // See Note [Dirty flags in the non-moving collector] in NonMoving.c ===================================== rts/win32/AsyncMIO.c ===================================== @@ -294,7 +294,7 @@ start: for(tso = iomgr->blocked_queue_hd; tso != END_TSO_QUEUE; tso = tso->_link) { - switch(tso->why_blocked) { + switch(ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnRead: case BlockedOnWrite: case BlockedOnDoProc: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf2b3041accc5df3f3c5a980a1f8e4e10a34a2e1...bc8eba8e67bb9b1134e0a4a210e3bf79acbf7ac5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf2b3041accc5df3f3c5a980a1f8e4e10a34a2e1...bc8eba8e67bb9b1134e0a4a210e3bf79acbf7ac5 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 Dec 16 13:36:20 2023 From: gitlab at gitlab.haskell.org (Ben Gamari (@bgamari)) Date: Sat, 16 Dec 2023 08:36:20 -0500 Subject: [Git][ghc/ghc][wip/tsan/fix-races] 8 commits: rts: Fix synchronization on thread blocking state Message-ID: <657da7d48bbed_e7a73284388d42034a5@gitlab.mail> Ben Gamari pushed to branch wip/tsan/fix-races at Glasgow Haskell Compiler / GHC Commits: 3a675865 by Ben Gamari at 2023-12-16T08:36:00-05:00 rts: Fix synchronization on thread blocking state We now use a release barrier whenever we update a thread's blocking state. This required widening StgTSO.why_blocked as AArch64 does not support atomic writes on 16-bit values. - - - - - bd07c396 by Ben Gamari at 2023-12-16T08:36:00-05:00 rts: Use relaxed ordering on dirty/clean info tables updates When changing the dirty/clean state of a mutable object we needn't have any particular ordering. - - - - - f46a5ffd by Ben Gamari at 2023-12-16T08:36:00-05:00 codeGen: Use relaxed-read in closureInfoPtr - - - - - 46e7bcc7 by Ben Gamari at 2023-12-16T08:36:00-05:00 STM: Use acquire loads when possible Full sequential consistency is not needed here. - - - - - 92d1a8af by Ben Gamari at 2023-12-16T08:36:00-05:00 rts/Messages: Fix data race - - - - - a2ffeafa by Ben Gamari at 2023-12-16T08:36:00-05:00 rts/Prof: Fix data race - - - - - 299ac1db by Ben Gamari at 2023-12-16T08:36:00-05:00 rts: Use fence rather than redundant load Previously we would use an atomic load to ensure acquire ordering. However, we now have `ACQUIRE_FENCE_ON`, which allows us to express this more directly. - - - - - d6e45c01 by Ben Gamari at 2023-12-16T08:36:00-05:00 rts: Fix data races in profiling timer - - - - - 22 changed files: - compiler/GHC/Cmm/Info.hs - rts/Exception.cmm - rts/Messages.c - rts/PrimOps.cmm - rts/Proftimer.c - rts/RaiseAsync.c - rts/STM.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/TraverseHeap.c - rts/include/rts/storage/ClosureMacros.h - rts/include/rts/storage/TSO.h - rts/include/stg/SMP.h - rts/posix/Select.c - rts/sm/Compact.c - rts/sm/GC.c - rts/sm/GCAux.c - rts/sm/NonMovingMark.c - rts/sm/Scav.c - rts/sm/Storage.c - rts/win32/AsyncMIO.c Changes: ===================================== compiler/GHC/Cmm/Info.hs ===================================== @@ -449,7 +449,7 @@ wordAligned platform align_check e -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e = - cmmLoadBWord platform (wordAligned platform align_check e) + CmmMachOp (MO_RelaxedRead (wordWidth platform)) [wordAligned platform align_check e] -- | Takes an info pointer (the first word of a closure) and returns its entry -- code ===================================== rts/Exception.cmm ===================================== @@ -351,9 +351,9 @@ stg_killThreadzh (P_ target, P_ exception) if (msg == NULL) { return (); } else { - StgTSO_why_blocked(CurrentTSO) = BlockedOnMsgThrowTo; updateRemembSetPushPtr(StgTSO_block_info(CurrentTSO)); StgTSO_block_info(CurrentTSO) = msg; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMsgThrowTo; // we must block, and unlock the message before returning jump stg_block_throwto (target, exception); } ===================================== rts/Messages.c ===================================== @@ -205,7 +205,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) StgTSO *owner = (StgTSO*)p; #if defined(THREADED_RTS) - if (owner->cap != cap) { + if (RELAXED_LOAD(&owner->cap) != cap) { sendMessage(cap, owner->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); @@ -275,7 +275,7 @@ uint32_t messageBlackHole(Capability *cap, MessageBlackHole *msg) ASSERT(owner != END_TSO_QUEUE); #if defined(THREADED_RTS) - if (owner->cap != cap) { + if (RELAXED_LOAD(&owner->cap) != cap) { sendMessage(cap, owner->cap, (Message*)msg); debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); ===================================== rts/PrimOps.cmm ===================================== @@ -827,7 +827,9 @@ stg_atomicModifyMutVarzuzh ( gcptr mv, gcptr f ) StgMutVar_var(mv) = z; #endif - if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) { + W_ info; + info = %relaxed GET_INFO(mv); + if (info == stg_MUT_VAR_CLEAN_info) { ccall dirty_MUT_VAR(BaseReg "ptr", mv "ptr", x "ptr"); } @@ -1715,21 +1717,17 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // Write barrier before we make the new MVAR_TSO_QUEUE - // visible to other cores. - // See Note [Heap memory barriers] - RELEASE_FENCE; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; + %release StgMVar_head(mvar) = q; } else { - StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; + %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); } StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I32; StgMVar_tail(mvar) = q; jump stg_block_takemvar(mvar); @@ -1770,7 +1768,7 @@ loop: StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); + ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I32); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the putMVar for the thread that we just woke up @@ -1838,7 +1836,7 @@ loop: StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); + ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I32); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the putMVar for the thread that we just woke up @@ -1884,19 +1882,17 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; + %release StgMVar_head(mvar) = q; } else { - StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; + %release StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); } StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I32; StgMVar_tail(mvar) = q; jump stg_block_putmvar(mvar,val); @@ -2033,11 +2029,11 @@ loop: } } - ASSERT(StgTSO_block_info(tso) == mvar); // save why_blocked here, because waking up the thread destroys // this information W_ why_blocked; - why_blocked = TO_W_(StgTSO_why_blocked(tso)); + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO: Missing barrier + ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the takeMVar W_ stack; @@ -2093,13 +2089,11 @@ stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; + %release StgMVar_head(mvar) = q; StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; - StgMVar_head(mvar) = q; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = q; @@ -2226,17 +2220,16 @@ stg_readIOPortzh ( P_ ioport /* :: IOPort a */ ) StgMVarTSOQueue_tso(q) = CurrentTSO; SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); - // See Note [Heap memory barriers] - RELEASE_FENCE; - StgMVar_head(ioport) = q; + %release StgMVar_head(ioport) = q; StgTSO__link(CurrentTSO) = q; StgTSO_block_info(CurrentTSO) = ioport; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + + // See Note [Heap memory barriers] + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I32; //Unlocks the closure as well jump stg_block_readmvar(ioport); - } //This way we can check of there has been a read already. @@ -2314,11 +2307,11 @@ loop: // next element in the waiting list here, as there can only ever // be one thread blocked on a port. - ASSERT(StgTSO_block_info(tso) == ioport); // save why_blocked here, because waking up the thread destroys // this information W_ why_blocked; - why_blocked = TO_W_(StgTSO_why_blocked(tso)); + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // TODO Missing acquire + ASSERT(StgTSO_block_info(tso) == ioport); // actually perform the takeMVar W_ stack; @@ -2559,9 +2552,9 @@ stg_waitReadzh ( W_ fd ) ccall barf("waitRead# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); StgTSO_block_info(CurrentTSO) = fd; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32; // No locking - we're not going to use this interface in the // threaded RTS anyway. ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); @@ -2575,9 +2568,9 @@ stg_waitWritezh ( W_ fd ) ccall barf("waitWrite# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); StgTSO_block_info(CurrentTSO) = fd; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32; // No locking - we're not going to use this interface in the // threaded RTS anyway. ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); @@ -2598,8 +2591,7 @@ stg_delayzh ( W_ us_delay ) ccall barf("delay# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16; + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); #if defined(mingw32_HOST_OS) @@ -2616,12 +2608,13 @@ stg_delayzh ( W_ us_delay ) * simplifies matters, so change the status to OnDoProc put the * delayed thread on the blocked_queue. */ - StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I32; ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async_void(); #else + %relaxed StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I32; (target) = ccall getDelayTarget(us_delay); StgTSO_block_info(CurrentTSO) = target; @@ -2643,9 +2636,6 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) ccall barf("asyncRead# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16; - /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncReadzh"); @@ -2654,6 +2644,10 @@ stg_asyncReadzh ( W_ fd, W_ is_sock, W_ len, W_ buf ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I32; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif @@ -2668,9 +2662,6 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) ccall barf("asyncWrite# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16; - ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncWritezh"); (reqID) = ccall addIORequest(fd, 1/*TRUE*/,is_sock,len,buf "ptr"); @@ -2679,6 +2670,10 @@ stg_asyncWritezh ( W_ fd, W_ is_sock, W_ len, W_ buf ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I32; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif @@ -2693,9 +2688,6 @@ stg_asyncDoProczh ( W_ proc, W_ param ) ccall barf("asyncDoProc# on threaded RTS") never returns; #else - ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); - StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16; - /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, "stg_asyncDoProczh"); @@ -2704,6 +2696,10 @@ stg_asyncDoProczh ( W_ proc, W_ param ) StgAsyncIOResult_len(ares) = 0; StgAsyncIOResult_errCode(ares) = 0; StgTSO_block_info(CurrentTSO) = ares; + + ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I32); + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I32; + ccall appendToIOBlockedQueue(MyCapability() "ptr", CurrentTSO "ptr"); jump stg_block_async(); #endif ===================================== rts/Proftimer.c ===================================== @@ -101,7 +101,7 @@ requestHeapCensus( void ){ void initProfTimer( void ) { - performHeapProfile = false; + RELAXED_STORE_ALWAYS(&performHeapProfile, false); ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; @@ -124,7 +124,8 @@ handleProfTick(void) uint32_t n; for (n=0; n < getNumCapabilities(); n++) { Capability *cap = getCapability(n); - cap->r.rCCCS->time_ticks++; + CostCentreStack *ccs = RELAXED_LOAD(&cap->r.rCCCS); + ccs->time_ticks++; traceProfSampleCostCentre(cap, cap->r.rCCCS, total_ticks); } } @@ -135,7 +136,7 @@ handleProfTick(void) ticks_to_ticky_sample--; if (ticks_to_ticky_sample <= 0) { ticks_to_ticky_sample = RtsFlags.ProfFlags.heapProfileIntervalTicks; - performTickySample = true; + RELAXED_STORE_ALWAYS(&performTickySample, true); } } #endif @@ -144,7 +145,7 @@ handleProfTick(void) ticks_to_heap_profile--; if (ticks_to_heap_profile <= 0) { ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; - performHeapProfile = true; + RELAXED_STORE_ALWAYS(&performHeapProfile, true); } } } ===================================== rts/RaiseAsync.c ===================================== @@ -266,7 +266,7 @@ check_target: return THROWTO_BLOCKED; } - status = target->why_blocked; + status = ACQUIRE_LOAD(&target->why_blocked); switch (status) { case NotBlocked: @@ -728,7 +728,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) } done: - tso->why_blocked = NotBlocked; + RELAXED_STORE(&tso->why_blocked, NotBlocked); appendToRunQueue(cap, tso); } ===================================== rts/STM.c ===================================== @@ -187,7 +187,7 @@ static StgClosure *lock_tvar(Capability *cap STG_UNUSED, StgTVar *s STG_UNUSED) { StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); return result; } @@ -198,7 +198,7 @@ static void unlock_tvar(Capability *cap, StgBool force_update) { TRACE("%p : unlock_tvar(%p)", trec, s); if (force_update) { - StgClosure *old_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *old_value = ACQUIRE_LOAD(&s->current_value); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, old_value); } @@ -210,7 +210,7 @@ static StgBool cond_lock_tvar(Capability *cap STG_UNUSED, StgClosure *expected) { StgClosure *result; TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); TRACE("%p : %s", trec, (result == expected) ? "success" : "failure"); return (result == expected); } @@ -231,7 +231,7 @@ static void lock_stm(StgTRecHeader *trec) { static void unlock_stm(StgTRecHeader *trec STG_UNUSED) { TRACE("%p : unlock_stm()", trec); ASSERT(smp_locked == trec); - SEQ_CST_STORE(&smp_locked, 0); + RELEASE_STORE(&smp_locked, 0); } static StgClosure *lock_tvar(Capability *cap STG_UNUSED, @@ -240,7 +240,7 @@ static StgClosure *lock_tvar(Capability *cap STG_UNUSED, StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); ASSERT(smp_locked == trec); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); return result; } @@ -252,7 +252,7 @@ static void *unlock_tvar(Capability *cap, TRACE("%p : unlock_tvar(%p, %p)", trec, s, c); ASSERT(smp_locked == trec); if (force_update) { - StgClosure *old_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *old_value = ACQUIRE_LOAD(&s->current_value); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, old_value); } @@ -265,7 +265,7 @@ static StgBool cond_lock_tvar(Capability *cap STG_UNUSED, StgClosure *result; TRACE("%p : cond_lock_tvar(%p, %p)", trec, s, expected); ASSERT(smp_locked == trec); - result = SEQ_CST_LOAD(&s->current_value); + result = ACQUIRE_LOAD(&s->current_value); TRACE("%p : %d", result ? "success" : "failure"); return (result == expected); } @@ -291,9 +291,11 @@ static StgClosure *lock_tvar(Capability *cap, StgClosure *result; TRACE("%p : lock_tvar(%p)", trec, s); do { + const StgInfoTable *info; do { - result = SEQ_CST_LOAD(&s->current_value); - } while (GET_INFO(UNTAG_CLOSURE(result)) == &stg_TREC_HEADER_info); + result = ACQUIRE_LOAD(&s->current_value); + info = GET_INFO(UNTAG_CLOSURE(result)); + } while (info == &stg_TREC_HEADER_info); } while (cas((void *) &s->current_value, (StgWord)result, (StgWord)trec) != (StgWord)result); @@ -311,7 +313,7 @@ static void unlock_tvar(Capability *cap, StgClosure *c, StgBool force_update STG_UNUSED) { TRACE("%p : unlock_tvar(%p, %p)", trec, s, c); - ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); + ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); RELEASE_STORE(&s->current_value, c); dirty_TVAR(cap, s, (StgClosure *) trec); } @@ -340,8 +342,8 @@ static StgBool cond_lock_tvar(Capability *cap, static void park_tso(StgTSO *tso) { ASSERT(tso -> why_blocked == NotBlocked); - tso -> why_blocked = BlockedOnSTM; tso -> block_info.closure = (StgClosure *) END_TSO_QUEUE; + RELEASE_STORE(&tso -> why_blocked, BlockedOnSTM); TRACE("park_tso on tso=%p", tso); } @@ -375,7 +377,7 @@ static void unpark_waiters_on(Capability *cap, StgTVar *s) { StgTVarWatchQueue *trail; TRACE("unpark_waiters_on tvar=%p", s); // unblock TSOs in reverse order, to be a bit fairer (#2319) - for (q = SEQ_CST_LOAD(&s->first_watch_queue_entry), trail = q; + for (q = ACQUIRE_LOAD(&s->first_watch_queue_entry), trail = q; q != END_STM_WATCH_QUEUE; q = q -> next_queue_entry) { trail = q; @@ -532,16 +534,16 @@ static void build_watch_queue_entries_for_trec(Capability *cap, StgTVarWatchQueue *fq; s = e -> tvar; TRACE("%p : adding tso=%p to watch queue for tvar=%p", trec, tso, s); - ACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); - NACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == e -> expected_value); - fq = SEQ_CST_LOAD(&s->first_watch_queue_entry); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); + NACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == e -> expected_value); + fq = ACQUIRE_LOAD(&s->first_watch_queue_entry); q = alloc_stg_tvar_watch_queue(cap, (StgClosure*) tso); q -> next_queue_entry = fq; q -> prev_queue_entry = END_STM_WATCH_QUEUE; if (fq != END_STM_WATCH_QUEUE) { fq -> prev_queue_entry = q; } - SEQ_CST_STORE(&s->first_watch_queue_entry, q); + RELEASE_STORE(&s->first_watch_queue_entry, q); e -> new_value = (StgClosure *) q; dirty_TVAR(cap, s, (StgClosure *) fq); // we modified first_watch_queue_entry }); @@ -569,7 +571,7 @@ static void remove_watch_queue_entries_for_trec(Capability *cap, trec, q -> closure, s); - ACQ_ASSERT(SEQ_CST_LOAD(&s->current_value) == (StgClosure *)trec); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) == (StgClosure *)trec); nq = q -> next_queue_entry; pq = q -> prev_queue_entry; if (nq != END_STM_WATCH_QUEUE) { @@ -578,8 +580,8 @@ static void remove_watch_queue_entries_for_trec(Capability *cap, if (pq != END_STM_WATCH_QUEUE) { pq -> next_queue_entry = nq; } else { - ASSERT(SEQ_CST_LOAD(&s->first_watch_queue_entry) == q); - SEQ_CST_STORE(&s->first_watch_queue_entry, nq); + ASSERT(ACQUIRE_LOAD(&s->first_watch_queue_entry) == q); + RELEASE_STORE(&s->first_watch_queue_entry, nq); dirty_TVAR(cap, s, (StgClosure *) q); // we modified first_watch_queue_entry } free_stg_tvar_watch_queue(cap, q); @@ -727,7 +729,7 @@ static StgBool entry_is_read_only(TRecEntry *e) { static StgBool tvar_is_locked(StgTVar *s, StgTRecHeader *h) { StgClosure *c; StgBool result; - c = SEQ_CST_LOAD(&s->current_value); + c = ACQUIRE_LOAD(&s->current_value); result = (c == (StgClosure *) h); return result; } @@ -803,13 +805,13 @@ static StgBool validate_and_acquire_ownership (Capability *cap, // The memory ordering here must ensure that we have two distinct // reads to current_value, with the read from num_updates between // them. - if (SEQ_CST_LOAD(&s->current_value) != e -> expected_value) { + if (ACQUIRE_LOAD(&s->current_value) != e -> expected_value) { TRACE("%p : doesn't match", trec); result = false; BREAK_FOR_EACH; } e->num_updates = SEQ_CST_LOAD(&s->num_updates); - if (SEQ_CST_LOAD(&s->current_value) != e -> expected_value) { + if (ACQUIRE_LOAD(&s->current_value) != e -> expected_value) { TRACE("%p : doesn't match (race)", trec); result = false; BREAK_FOR_EACH; @@ -852,7 +854,7 @@ static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) { // We must first load current_value then num_updates; this is inverse of // the order of the stores in stmCommitTransaction. - StgClosure *current_value = SEQ_CST_LOAD(&s->current_value); + StgClosure *current_value = ACQUIRE_LOAD(&s->current_value); StgInt num_updates = SEQ_CST_LOAD(&s->num_updates); // Note we need both checks and in this order as the TVar could be @@ -1186,7 +1188,7 @@ StgBool stmCommitNestedTransaction(Capability *cap, StgTRecHeader *trec) { unlock_tvar(cap, trec, s, e -> expected_value, false); } merge_update_into(cap, et, s, e -> expected_value, e -> new_value); - ACQ_ASSERT(s -> current_value != (StgClosure *)trec); + ACQ_ASSERT(ACQUIRE_LOAD(&s->current_value) != (StgClosure *)trec); }); } else { revert_ownership(cap, trec, false); ===================================== rts/Schedule.c ===================================== @@ -512,7 +512,8 @@ run_thread: #endif if (ret == ThreadBlocked) { - if (t->why_blocked == BlockedOnBlackHole) { + uint16_t why_blocked = ACQUIRE_LOAD(&t->why_blocked); + if (why_blocked == BlockedOnBlackHole) { StgTSO *owner = blackHoleOwner(t->block_info.bh->bh); traceEventStopThread(cap, t, t->why_blocked + 6, owner != NULL ? owner->id : 0); @@ -1385,7 +1386,7 @@ scheduleNeedHeapProfile( bool ready_to_gc ) { // When we have +RTS -i0 and we're heap profiling, do a census at // every GC. This lets us get repeatable runs for debugging. - if (performHeapProfile || + if (RELAXED_LOAD(&performHeapProfile) || (RtsFlags.ProfFlags.heapProfileInterval==0 && RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) { return true; @@ -1946,7 +1947,7 @@ delete_threads_and_gc: // The heap census itself is done during GarbageCollect(). if (heap_census) { - performHeapProfile = false; + RELAXED_STORE(&performHeapProfile, false); } #if defined(THREADED_RTS) ===================================== rts/StgMiscClosures.cmm ===================================== @@ -606,8 +606,8 @@ retry: if (r == 0) { goto retry; } else { - StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16; StgTSO_block_info(CurrentTSO) = msg; + %release StgTSO_why_blocked(CurrentTSO) = BlockedOnBlackHole::I16; jump stg_block_blackhole(node); } } ===================================== rts/Threads.c ===================================== @@ -94,8 +94,8 @@ createThread(Capability *cap, W_ size) // Always start with the compiled code evaluator tso->what_next = ThreadRunGHC; - tso->why_blocked = NotBlocked; tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; + tso->why_blocked = NotBlocked; tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE; tso->bq = (StgBlockingQueue *)END_TSO_QUEUE; tso->flags = 0; @@ -286,7 +286,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) } #endif - switch (tso->why_blocked) + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: @@ -826,10 +826,11 @@ loop: } } - ASSERT(tso->block_info.closure == (StgClosure*)mvar); // save why_blocked here, because waking up the thread destroys // this information - StgWord why_blocked = RELAXED_LOAD(&tso->why_blocked); + StgWord why_blocked = ACQUIRE_LOAD(&tso->why_blocked); + ASSERT(why_blocked == BlockedOnMVarRead || why_blocked == BlockedOnMVar); + ASSERT(tso->block_info.closure == (StgClosure*)mvar); // actually perform the takeMVar StgStack* stack = tso->stackobj; @@ -903,7 +904,7 @@ StgMutArrPtrs *listThreads(Capability *cap) void printThreadBlockage(StgTSO *tso) { - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { #if defined(mingw32_HOST_OS) case BlockedOnDoProc: debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID); ===================================== rts/TraverseHeap.c ===================================== @@ -1239,7 +1239,7 @@ inner_loop: traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, sep, child_data); traversePushClosure(ts, (StgClosure *) tso->bq, c, sep, child_data); traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data); - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/include/rts/storage/ClosureMacros.h ===================================== @@ -184,7 +184,7 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con) // Use when changing a closure from one kind to another #define OVERWRITE_INFO(c, new_info) \ OVERWRITING_CLOSURE((StgClosure *)(c)); \ - SET_INFO((StgClosure *)(c), (new_info)); \ + SET_INFO_RELAXED((StgClosure *)(c), (new_info)); \ LDV_RECORD_CREATE(c); /* ----------------------------------------------------------------------------- ===================================== rts/include/rts/storage/TSO.h ===================================== @@ -126,9 +126,14 @@ typedef struct StgTSO_ { */ StgWord16 what_next; // Values defined in Constants.h - StgWord16 why_blocked; // Values defined in Constants.h StgWord32 flags; // Values defined in Constants.h - StgTSOBlockInfo block_info; + + /* + * N.B. why_blocked only has a handful of values but must be atomically + * updated; the smallest width which AArch64 supports for is 32-bits. + */ + StgWord32 why_blocked; // Values defined in Constants.h + StgTSOBlockInfo block_info; // Barrier provided by why_blocked StgThreadID id; StgWord32 saved_errno; StgWord32 dirty; /* non-zero => dirty */ ===================================== rts/include/stg/SMP.h ===================================== @@ -218,6 +218,7 @@ EXTERN_INLINE void busy_wait_nop(void); * - StgSmallMutArrPtrs: payload * - StgThunk although this is a somewhat special case; see below * - StgInd: indirectee + * - StgTSO: block_info * * Finally, non-pointer fields can be safely mutated without barriers as * they do not refer to other memory locations. Technically, concurrent @@ -346,6 +347,14 @@ EXTERN_INLINE void busy_wait_nop(void); * the capability-local mut_list. Consequently this does not require any memory * barrier. * + * Barriers in thread blocking + * --------------------------- + * When a thread blocks (e.g. on an MVar) it will typically allocate a heap object + * to record its blocked-ness (e.g. a StgMVarTSOQueue), expose this via + * StgTSO.block_info, and update StgTSO.why_blocked to record the reason for + * its blocking. The visibility of the block_info is guaranteed by the ordering + * of the why_blocked update. + * * Barriers in thread migration * ---------------------------- * When a thread is migrated from one capability to another we must take care ===================================== rts/posix/Select.c ===================================== @@ -105,7 +105,7 @@ static bool wakeUpSleepingThreads (Capability *cap, LowResTime now) break; } iomgr->sleeping_queue = tso->_link; - tso->why_blocked = NotBlocked; + RELAXED_STORE(&tso->why_blocked, NotBlocked); tso->_link = END_TSO_QUEUE; IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %" FMT_StgThreadID "\n", tso->id)); @@ -268,7 +268,7 @@ awaitEvent(Capability *cap, bool wait) * So the (int) cast should be removed across the code base once * GHC requires a version of FreeBSD that has that change in it. */ - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnRead: { int fd = tso->block_info.fd; ===================================== rts/sm/Compact.c ===================================== @@ -463,7 +463,7 @@ thread_TSO (StgTSO *tso) thread_(&tso->_link); thread_(&tso->global_link); - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/GC.c ===================================== @@ -340,8 +340,8 @@ GarbageCollect (struct GcConfig config, // attribute any costs to CCS_GC #if defined(PROFILING) for (n = 0; n < getNumCapabilities(); n++) { - save_CCS[n] = getCapability(n)->r.rCCCS; - getCapability(n)->r.rCCCS = CCS_GC; + save_CCS[n] = RELAXED_LOAD(&getCapability(n)->r.rCCCS); + RELAXED_STORE(&getCapability(n)->r.rCCCS, CCS_GC); } #endif @@ -979,9 +979,9 @@ GarbageCollect (struct GcConfig config, // Post ticky counter sample. // We do this at the end of execution since tickers are registered in the // course of program execution. - if (performTickySample) { + if (RELAXED_LOAD(&performTickySample)) { emitTickyCounterSamples(); - performTickySample = false; + RELAXED_STORE(&performTickySample, false); } #endif ===================================== rts/sm/GCAux.c ===================================== @@ -91,7 +91,7 @@ isAlive(StgClosure *p) return TAG_CLOSURE(tag,(StgClosure*)UN_FORWARDING_PTR(info)); } - info = ACQUIRE_LOAD(&q->header.info); + ACQUIRE_FENCE_ON(&q->header.info); info = INFO_PTR_TO_STRUCT(info); switch (info->type) { ===================================== rts/sm/NonMovingMark.c ===================================== @@ -1052,7 +1052,7 @@ trace_tso (MarkQueue *queue, StgTSO *tso) if (tso->label != NULL) { markQueuePushClosure_(queue, (StgClosure *) tso->label); } - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/Scav.c ===================================== @@ -137,7 +137,7 @@ scavengeTSO (StgTSO *tso) evacuate((StgClosure **)&tso->label); } - switch (tso->why_blocked) { + switch (ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnMVar: case BlockedOnMVarRead: case BlockedOnBlackHole: ===================================== rts/sm/Storage.c ===================================== @@ -1440,7 +1440,7 @@ dirty_MUT_VAR(StgRegTable *reg, StgMutVar *mvar, StgClosure *old) Capability *cap = regTableToCapability(reg); // No barrier required here as no other heap object fields are read. See // Note [Heap memory barriers] in SMP.h. - SET_INFO((StgClosure*) mvar, &stg_MUT_VAR_DIRTY_info); + SET_INFO_RELAXED((StgClosure*) mvar, &stg_MUT_VAR_DIRTY_info); recordClosureMutated(cap, (StgClosure *) mvar); IF_NONMOVING_WRITE_BARRIER_ENABLED { // See Note [Dirty flags in the non-moving collector] in NonMoving.c @@ -1462,7 +1462,7 @@ dirty_TVAR(Capability *cap, StgTVar *p, // No barrier required here as no other heap object fields are read. See // Note [Heap memory barriers] in SMP.h. if (RELAXED_LOAD(&p->header.info) == &stg_TVAR_CLEAN_info) { - SET_INFO((StgClosure*) p, &stg_TVAR_DIRTY_info); + SET_INFO_RELAXED((StgClosure*) p, &stg_TVAR_DIRTY_info); recordClosureMutated(cap,(StgClosure*)p); IF_NONMOVING_WRITE_BARRIER_ENABLED { // See Note [Dirty flags in the non-moving collector] in NonMoving.c ===================================== rts/win32/AsyncMIO.c ===================================== @@ -294,7 +294,7 @@ start: for(tso = iomgr->blocked_queue_hd; tso != END_TSO_QUEUE; tso = tso->_link) { - switch(tso->why_blocked) { + switch(ACQUIRE_LOAD(&tso->why_blocked)) { case BlockedOnRead: case BlockedOnWrite: case BlockedOnDoProc: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc8eba8e67bb9b1134e0a4a210e3bf79acbf7ac5...d6e45c01d61bf4cb300f4192794b059e4a2697b6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bc8eba8e67bb9b1134e0a4a210e3bf79acbf7ac5...d6e45c01d61bf4cb300f4192794b059e4a2697b6 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 Dec 16 14:27:29 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Sat, 16 Dec 2023 09:27:29 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24264 Message-ID: <657db3d1b5b54_e7a7329b6dc48203948@gitlab.mail> Matthew Craven pushed new branch wip/T24264 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24264 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 Dec 16 17:23:13 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sat, 16 Dec 2023 12:23:13 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] 3 commits: EPA: Remove some unneeded helpers from Parser.y Message-ID: <657ddd01b6460_e7a732dc0443c209457@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 95e75b05 by Alan Zimmerman at 2023-12-16T15:28:04+00:00 EPA: Remove some unneeded helpers from Parser.y - - - - - 929bad3a by Alan Zimmerman at 2023-12-16T16:37:25+00:00 EPA: remove double calculation from acs and acsA - - - - - 7cee320f by Alan Zimmerman at 2023-12-16T17:20:32+00:00 EPA: remove more uneccesary helpers in Parser.y - - - - - 2 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -758,10 +758,10 @@ identifier :: { LocatedN RdrName } | qcon { $1 } | qvarop { $1 } | qconop { $1 } - | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) } - | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) } + | '(' '->' ')' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) } + | '->' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) } ----------------------------------------------------------------------------- -- Backpack stuff @@ -880,7 +880,7 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located (HsModule GhcPs) } : 'signature' modid maybe_warning_pragma maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - acs (\cs-> (L loc (HsModule (XModulePs + acs loc (\loc cs-> (L loc (HsModule (XModulePs (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs) (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) @@ -938,14 +938,14 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located (HsModule GhcPs) } : 'module' modid maybe_warning_pragma maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (XModulePs + acs loc (\loc cs -> (L loc (HsModule (XModulePs (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs) EpNoLayout $3 Nothing) (Just $2) $4 $6 [] ))) } | 'signature' modid maybe_warning_pragma maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (XModulePs + acs loc (\loc cs -> (L loc (HsModule (XModulePs (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs) EpNoLayout $3 Nothing) (Just $2) $4 $6 [] @@ -973,7 +973,7 @@ header_top_importdecls :: { [LImportDecl GhcPs] } -- The Export List maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) } - : '(' exportlist ')' {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2)) + : '(' exportlist ')' {% fmap Just $ amsr (sLL $1 $> (fromOL $ snd $2)) (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) } | {- empty -} { Nothing } @@ -1103,7 +1103,7 @@ importdecl :: { LImportDecl GhcPs } , importDeclAnnAs = fst $8 } ; let loc = (comb5 $1 $6 $7 (snd $8) $9); - ; fmap reLoc $ acs (\cs -> L loc $ + ; fmap reLoc $ acs loc (\loc cs -> L loc $ ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 @@ -1148,10 +1148,10 @@ maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs] | {- empty -} { noLoc Nothing } impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) } - : '(' importlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2) + : '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $2) (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) ; return $ sLL $1 $> (Exactly, es)} } - | 'hiding' '(' importlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3) + | 'hiding' '(' importlist ')' {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $3) (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) []) ; return $ sLL $1 $> (EverythingBut, es)} } @@ -1368,13 +1368,13 @@ inst_decl :: { LInstDecl GhcPs } :(fst $ unLoc $5)++(fst $ unLoc $6)) } overlap_pragma :: { Maybe (LocatedP OverlapMode) } - : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) + : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) (AnnPragma (mo $1) (mc $2) []) } - | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) + | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) (AnnPragma (mo $1) (mc $2) []) } - | '{-# OVERLAPS' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) + | '{-# OVERLAPS' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) (AnnPragma (mo $1) (mc $2) []) } - | '{-# INCOHERENT' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) + | '{-# INCOHERENT' '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) (AnnPragma (mo $1) (mc $2) []) } | {- empty -} { Nothing } @@ -1570,14 +1570,14 @@ opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs -- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } - : context '=>' type {% acs (\cs -> (sLL $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) } + : context '=>' type {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), $3))) } | type { sL1 $1 (Nothing, $1) } datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) } : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1 >> fromSpecTyVarBndrs $2 >>= \tvbs -> - (acs (\cs -> (sLL $1 $> + (acs (comb2 $1 $>) (\loc cs -> (L loc (Just ( addTrailingDarrowC $4 $5 cs) , mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6)))) } @@ -1587,18 +1587,18 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs ; cs <- getCommentsFor loc ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4)) } } - | context '=>' type {% acs (\cs -> (sLL $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) } + | context '=>' type {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) } | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } capi_ctype :: { Maybe (LocatedP CType) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) + {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) (getSTRINGs $3,getSTRING $3))) (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) } | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) + {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) } | { Nothing } @@ -1674,9 +1674,9 @@ cvars1 :: { [RecordPatSynField GhcPs] } ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) } - : 'where' '{' decls '}' {% amsrl (sLL $1 $> (snd $ unLoc $3)) + : 'where' '{' decls '}' {% amsr (sLL $1 $> (snd $ unLoc $3)) (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) (mj AnnWhere $1: (fst $ unLoc $3)) []) } - | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3)) + | 'where' vocurly decls close {% amsr (sLL $1 $3 (snd $ unLoc $3)) (AnnList (Just $ glR $3) Nothing Nothing (mj AnnWhere $1: (fst $ unLoc $3)) []) } pattern_synonym_sig :: { LSig GhcPs } @@ -1828,18 +1828,18 @@ binds :: { Located (HsLocalBinds GhcPs) } ; cs <- getCommentsFor (gl $1) ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} } - | '{' dbinds '}' {% acs (\cs -> (L (comb3 $1 $2 $3) + | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } - | vocurly dbinds close {% acs (\cs -> (L (gl $2) + | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) } -- May have implicit parameters -- No type declarations - : 'where' binds {% do { r <- acs (\cs -> - (sLL $1 $> (annBinds (mj AnnWhere $1) cs (unLoc $2)))) + : 'where' binds {% do { r <- acs (comb2 $1 $>) (\loc cs -> + (L loc (annBinds (mj AnnWhere $1) cs (unLoc $2)))) ; return $ Just r} } | {- empty -} { Nothing } @@ -1954,10 +1954,10 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) + {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) } | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3)) + {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3)) (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))} | {- empty -} { Nothing } @@ -2134,11 +2134,11 @@ unpackedness :: { Located UnpackednessPragma } forall_telescope :: { Located (HsForAllTelescope GhcPs) } : 'forall' tv_bndrs '.' {% do { hintExplicitForall $1 - ; acs (\cs -> (sLL $1 $> $ + ; acs (comb2 $1 $>) (\loc cs -> (L loc $ mkHsForAllInvisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }} | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1 ; req_tvbs <- fromSpecTyVarBndrs $2 - ; acs (\cs -> (sLL $1 $> $ + ; acs (comb2 $1 $>) (\loc cs -> (L loc $ mkHsForAllVisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }} -- A ktype is a ctype, possibly with a kind annotation @@ -2152,7 +2152,7 @@ ctype :: { LHsType GhcPs } HsForAllTy { hst_tele = unLoc $1 , hst_xforall = noExtField , hst_body = $2 } } - | context '=>' ctype {% acsA (\cs -> (sLL $1 $> $ + | context '=>' ctype {% acsA (comb2 $1 $>) (\loc cs -> (L loc $ HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs , hst_xqual = NoExtField , hst_body = $3 })) } @@ -2232,11 +2232,11 @@ tyarg :: { LHsType GhcPs } tyop :: { (LocatedN RdrName, PromotionFlag) } : qtyconop { ($1, NotPromoted) } | tyvarop { ($1, NotPromoted) } - | SIMPLEQUOTE qconop {% do { op <- amsrn (sLL $1 $> (unLoc $2)) - (NameAnnQuote (glAA $1) (gl $2) []) + | SIMPLEQUOTE qconop {% do { op <- amsr (sLL $1 $> (unLoc $2)) + (NameAnnQuote (glAA $1) (gl $2) []) ; return (op, IsPromoted) } } - | SIMPLEQUOTE varop {% do { op <- amsrn (sLL $1 $> (unLoc $2)) - (NameAnnQuote (glAA $1) (gl $2) []) + | SIMPLEQUOTE varop {% do { op <- amsr (sLL $1 $> (unLoc $2)) + (NameAnnQuote (glAA $1) (gl $2) []) ; return (op, IsPromoted) } } atype :: { LHsType GhcPs } @@ -2514,10 +2514,10 @@ deriv_clause_types :: { LDerivClauseTys GhcPs } : qtycon { let { tc = sL1a $1 $ mkHsImplicitSigType $ sL1a $1 $ HsTyVar noAnn NotPromoted $1 } in sL1a $1 (DctSingle noExtField tc) } - | '(' ')' {% amsrc (sLL $1 $> (DctMulti noExtField [])) - (AnnContext Nothing [glAA $1] [glAA $2]) } - | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2)) - (AnnContext Nothing [glAA $1] [glAA $3])} + | '(' ')' {% amsr (sLL $1 $> (DctMulti noExtField [])) + (AnnContext Nothing [glAA $1] [glAA $2]) } + | '(' deriv_types ')' {% amsr (sLL $1 $> (DctMulti noExtField $2)) + (AnnContext Nothing [glAA $1] [glAA $3])} ----------------------------------------------------------------------------- -- Value definitions @@ -2581,11 +2581,11 @@ rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) } do { let L l (bs, csw) = adaptWhereBinds $3 ; let loc = (comb3 $1 $2 (L l bs)) ; let locg = (comb2 $1 $2) - ; acs (\cs -> - sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs locg) (GrhsAnn Nothing (mj AnnEqual $1)) cs) locg $2) + ; acs loc (\loc cs -> + sL loc (GRHSs csw (unguardedRHS (EpAnn (spanAsAnchor locg) (GrhsAnn Nothing (mj AnnEqual $1)) cs) locg $2) bs)) } } | gdrhs wherebinds {% do { let {L l (bs, csw) = adaptWhereBinds $2} - ; acs (\cs -> sL (comb2 $1 (L l bs)) + ; acs (comb2 $1 (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }} gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } @@ -2594,7 +2594,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 -> - acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) } + acsA (comb2 $1 $>) (\loc cs -> L loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) } sigdecl :: { LHsDecl GhcPs } : @@ -2986,10 +2986,10 @@ aexp2 :: { ECP } [moh $1,mch $3] } | '[' list ']' { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) } - | '_' { ECP $ pvA $ mkHsWildCardPV (getLoc $1) } + | '_' { ECP $ mkHsWildCardPV (getLoc $1) } -- Template Haskell Extension - | splice_untyped { ECP $ pvA' $ mkHsSplicePV $1 } + | splice_untyped { ECP $ mkHsSplicePV $1 } | splice_typed { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) } | SIMPLEQUOTE qvar {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True $2)) } @@ -3012,7 +3012,7 @@ aexp2 :: { ECP } amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (PatBr noExtField p)) } | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket (mo $1:mu AnnCloseQ $3:fst $2) (DecBrL noExtField (snd $2))) } - | quasiquote { ECP $ pvA' $ mkHsSplicePV $1 } + | quasiquote { ECP $ mkHsSplicePV $1 } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> @@ -3090,7 +3090,7 @@ texp :: { ECP } superInfixOp $ unECP $2 >>= \ $2 -> $1 >>= \ $1 -> - pvA' $ mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 } + mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 } -- View patterns get parenthesized above | exp '->' texp { ECP $ @@ -3110,7 +3110,7 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) } ; return (Tuple (Right t : snd $2)) } } | commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) True emptyComments))) (fst $1) } + do { let {cos = map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) } ; return (Tuple (cos ++ $2)) } } | texp bars { unECP $1 >>= \ $1 -> return $ @@ -3126,7 +3126,7 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) } commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)]) } commas_tup_tail : commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) True emptyComments))) (tail $ fst $1) } + do { let {cos = map (\l -> (Left (EpAnn (spanAsAnchor l) True emptyComments))) (tail $ fst $1) } ; return ((head $ fst $1, cos ++ $2)) } } -- Always follows a comma @@ -3219,14 +3219,14 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau {% case unLoc $1 of (h:t) -> do h' <- addTrailingCommaA h (gl $2) - return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) } + return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (reverse (h':t)))]) } | squals ',' qual {% runPV $3 >>= \ $3 -> case unLoc $1 of (h:t) -> do h' <- addTrailingCommaA h (gl $2) return (sLL $1 $> ($3 : (h':t))) } - | transformqual { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])] } + | transformqual { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) [])] } | qual {% runPV $1 >>= \ $1 -> return $ sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } @@ -3237,22 +3237,22 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } +transformqual :: { Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* : 'then' exp {% runPV (unECP $2) >>= \ $2 -> return ( - sLL $1 $> (\r ss -> (mkTransformStmt [mj AnnThen $1] ss $2))) } + sLL $1 $> (\ss -> (mkTransformStmt [mj AnnThen $1] ss $2))) } | 'then' exp 'by' exp {% runPV (unECP $2) >>= \ $2 -> runPV (unECP $4) >>= \ $4 -> - return (sLL $1 $> (\r ss -> (mkTransformByStmt [mj AnnThen $1,mj AnnBy $3] ss $2 $4))) } + return (sLL $1 $> (\ss -> (mkTransformByStmt [mj AnnThen $1,mj AnnBy $3] ss $2 $4))) } | 'then' 'group' 'using' exp {% runPV (unECP $4) >>= \ $4 -> - return (sLL $1 $> (\r ss -> (mkGroupUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] ss $4))) } + return (sLL $1 $> (\ss -> (mkGroupUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] ss $4))) } | 'then' 'group' 'by' exp 'using' exp {% runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> - return (sLL $1 $> (\r ss -> (mkGroupByUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] ss $4 $6))) } + return (sLL $1 $> (\ss -> (mkGroupByUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] ss $4 $6))) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this @@ -3278,13 +3278,13 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- Case alternatives altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) } - : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsrl + : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsr (sLL $1 $> (reverse (snd $ unLoc $2))) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } - | vocurly alts(PATS) close { $2 >>= \ $2 -> amsrl + | vocurly alts(PATS) close { $2 >>= \ $2 -> amsr (L (getLoc $2) (reverse (snd $ unLoc $2))) (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } - | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } + | '{' '}' { amsr (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } | vocurly close { return $ noLocA [] } alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) } @@ -3314,7 +3314,7 @@ alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } : PATS alt_rhs { $2 >>= \ $2 -> - acsA (\cs -> sLLAsl $1 $> + acsA (sLLAsl $1 $> ()) (\loc cs -> L (locA loc) (Match { m_ext = [] , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing , m_pats = $1 @@ -3323,11 +3323,11 @@ alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) } : ralt wherebinds { $1 >>= \alt -> do { let {L l (bs, csw) = adaptWhereBinds $2} - ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }} + ; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }} ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) } : '->' exp { unECP $2 >>= \ $2 -> - acs (\cs -> sLL $1 $> (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) } + acs (comb2 $1 $>) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) } | gdpats { $1 >>= \gdpats -> return $ sL1 gdpats (reverse (unLoc gdpats)) } @@ -3349,7 +3349,7 @@ ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) } : '|' guardquals '->' exp { unECP $4 >>= \ $4 -> - acsA (\cs -> sL (comb2 $1 $>) $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) } + acsA (comb2 $1 $>) (\loc cs -> sL loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) } -- 'pat' recognises a pattern, including one with a bang at the top -- e.g. "!x" or "!(x,y)" or "C a b" etc @@ -3380,8 +3380,8 @@ apats :: { [LPat GhcPs] } stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) } : '{' stmts '}' { $2 >>= \ $2 -> - amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) } - | vocurly stmts close { $2 >>= \ $2 -> amsrl + amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) } + | vocurly stmts close { $2 >>= \ $2 -> amsr (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) } -- do { ;; s ; s ; ; s ;; } @@ -3553,7 +3553,7 @@ name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] } ; return (h : $3) } } name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) } - : '(' name_boolformula ')' {% amsrl (sLL $1 $> (Parens $2)) + : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2)) (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) } | name_var { sL1a $1 (Var $1) } @@ -3581,13 +3581,13 @@ qcon :: { LocatedN RdrName } gen_qcon :: { LocatedN RdrName } : qconid { $1 } - | '(' qconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + | '(' qconsym ')' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } con :: { LocatedN RdrName } : conid { $1 } - | '(' consym ')' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + | '(' consym ')' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } con_list :: { Located (NonEmpty (LocatedN RdrName)) } @@ -3601,27 +3601,27 @@ qcon_list : qcon { sL1 $1 [$1] } -- See Note [ExplicitTuple] in GHC.Hs.Expr sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors - : '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } - | '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) + : '(' ')' {% amsr (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } + | '(' commas ')' {% amsr (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } - | '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } - | '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) + | '(#' '#)' {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } + | '(#' commas '#)' {% amsr (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } -- See Note [Empty lists] in GHC.Hs.Expr sysdcon :: { LocatedN DataCon } : sysdcon_nolist { $1 } - | '[' ']' {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } + | '[' ']' {% amsr (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } conop :: { LocatedN RdrName } : consym { $1 } - | '`' conid '`' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } + | '`' conid '`' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } qconop :: { LocatedN RdrName } : qconsym { $1 } - | '`' qconid '`' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } + | '`' qconid '`' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } ---------------------------------------------------------------------------- -- Type constructors @@ -3631,30 +3631,30 @@ qconop :: { LocatedN RdrName } -- between gtycon and ntgtycon gtycon :: { LocatedN RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } - | '(' ')' {% amsrn (sLL $1 $> $ getRdrName unitTyCon) - (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } - | '(#' '#)' {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon) - (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } + | '(' ')' {% amsr (sLL $1 $> $ getRdrName unitTyCon) + (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } + | '(#' '#)' {% amsr (sLL $1 $> $ getRdrName unboxedUnitTyCon) + (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit tuples : oqtycon { $1 } - | '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed - (snd $2 + 1))) + | '(' commas ')' {% amsr (sLL $1 $> $ getRdrName (tupleTyCon Boxed + (snd $2 + 1))) (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } - | '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed - (snd $2 + 1))) + | '(#' commas '#)' {% amsr (sLL $1 $> $ getRdrName (tupleTyCon Unboxed + (snd $2 + 1))) (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } - | '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1))) + | '(#' bars '#)' {% amsr (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1))) (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } - | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + | '(' '->' ')' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon) (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) } - | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR) + | '[' ']' {% amsr (sLL $1 $> $ listTyCon_RDR) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } oqtycon :: { LocatedN RdrName } -- An "ordinary" qualified tycon; -- These can appear in export lists : qtycon { $1 } - | '(' qtyconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + | '(' qtyconsym ')' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be mistaken @@ -3663,13 +3663,13 @@ oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be m : qtycon { $1 } | '(' QCONSYM ')' {% let { name :: Located RdrName ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } - in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '(' CONSYM ')' {% let { name :: Located RdrName ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } - in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '(' ':' ')' {% let { name :: Located RdrName ; name = sL1 $2 $! consDataCon_RDR } - in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } {- Note [Type constructors in export list] ~~~~~~~~~~~~~~~~~~~~~ @@ -3694,8 +3694,8 @@ child. qtyconop :: { LocatedN RdrName } -- Qualified or unqualified -- See Note [%shift: qtyconop -> qtyconsym] : qtyconsym %shift { $1 } - | '`' qtycon '`' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } + | '`' qtycon '`' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } qtycon :: { LocatedN RdrName } -- Qualified or unqualified : QCONID { sL1n $1 $! mkQual tcClsName (getQCONID $1) } @@ -3720,8 +3720,8 @@ tyconsym :: { LocatedN RdrName } -- These can appear in `ANN type` declarations (#19374). otycon :: { LocatedN RdrName } : tycon { $1 } - | '(' tyconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) - (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + | '(' tyconsym ')' {% amsr (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } ----------------------------------------------------------------------------- -- Operators @@ -3729,12 +3729,12 @@ otycon :: { LocatedN RdrName } op :: { LocatedN RdrName } -- used in infix decls : varop { $1 } | conop { $1 } - | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + | '->' {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon) (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) } varop :: { LocatedN RdrName } : varsym { $1 } - | '`' varid '`' {% amsrn (sLL $1 $> (unLoc $2)) + | '`' varid '`' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } qop :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections @@ -3752,12 +3752,12 @@ hole_op : '`' '_' '`' { sLLa $1 $> (hsHoleExpr (Just $ EpAnnUnboundVar qvarop :: { LocatedN RdrName } : qvarsym { $1 } - | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) + | '`' qvarid '`' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } qvaropm :: { LocatedN RdrName } : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) + | '`' qvarid '`' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } ----------------------------------------------------------------------------- @@ -3767,7 +3767,7 @@ tyvar :: { LocatedN RdrName } tyvar : tyvarid { $1 } tyvarop :: { LocatedN RdrName } -tyvarop : '`' tyvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) +tyvarop : '`' tyvarid '`' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) } tyvarid :: { LocatedN RdrName } @@ -3785,14 +3785,14 @@ tyvarid :: { LocatedN RdrName } var :: { LocatedN RdrName } : varid { $1 } - | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + | '(' varsym ')' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } qvar :: { LocatedN RdrName } : qvarid { $1 } - | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + | '(' varsym ')' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } - | '(' qvarsym1 ')' {% amsrn (sLL $1 $> (unLoc $2)) + | '(' qvarsym1 ')' {% amsr (sLL $1 $> (unLoc $2)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } -- We've inlined qvarsym here so that the decision about -- whether it's a qvar or a var can be postponed until @@ -4285,22 +4285,12 @@ gl = getLoc glA :: HasLoc a => a -> SrcSpan glA = getHasLoc -glRR :: Located a -> RealSrcSpan -glRR = realSrcSpan . getLoc - glR :: HasLoc a => a -> Anchor glR la = EpaSpan (getHasLoc la) -glMR :: Maybe (Located a) -> Located b -> Anchor -glMR (Just la) _ = glR la -glMR _ la = glR la - glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor glEE x y = spanAsAnchor $ comb2 x y -anc :: RealSrcSpan -> Anchor -anc r = EpaSpan (RealSrcSpan r Strict.Nothing) - glRM :: Located a -> Maybe Anchor glRM (L l _) = Just $ spanAsAnchor l @@ -4322,22 +4312,19 @@ acsFinal a = do Strict.Just (pos `Strict.And` gap) -> Just (pos,gap) return (a (cs Semi.<> csf) ce) -acs :: (HasLoc t, MonadP m) => (EpAnnComments -> GenLocated t a) -> m (GenLocated t a) -acs a = do - let (L l _) = a emptyComments +acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a) +acs l a = do cs <- getCommentsFor (locA l) - return (a cs) + return (a l cs) -acsA :: (HasLoc t, HasAnnotation t, MonadP m) => (EpAnnComments -> Located a) -> m (GenLocated t a) -acsA a = reLoc <$> acs a - -acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP -acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acs a - ; return (ecpFromExp $ expr) } +acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a) +acsA l a = do + cs <- getCommentsFor (locA l) + return $ reLoc (a l cs) ams1 :: MonadP m => Located a -> b -> m (LocatedA b) ams1 (L l a) b = do - cs <- getCommentsFor (locA l) + cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) b) amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a) @@ -4355,23 +4342,8 @@ amsAl (L l a) loc bs = do cs <- getCommentsFor loc return (L (addAnnsA l bs cs) a) -amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a) -amsrc a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnC bs cs a) - -amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a) -amsrl a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnL bs cs a) - -amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a) -amsrp a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnL bs cs a) - -amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a) -amsrn (L l a) an = do +amsr :: MonadP m => Located a -> an -> m (LocatedAn an a) +amsr (L l a) an = do cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) an cs) a) @@ -4396,22 +4368,6 @@ mos,mcs :: Located Token -> AddEpAnn mos ll = mj AnnOpenS ll mcs ll = mj AnnCloseS ll -pvA :: (MonadP m, NoAnn t) => m (Located a) -> m (LocatedAn t a) -pvA a = do { av <- a - ; return (reLoc av) } - -pvA' :: (MonadP m, NoAnn t) => m (LocatedAn t a) -> m (LocatedAn t a) -pvA' a = do { av <- a - ; return av } - -pvN :: MonadP m => m (LocatedN a) -> m (LocatedN a) -pvN a = do { (L l av) <- a - ; return (L l av) } - -pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) -pvL a = do { av <- a - ; return (reLoc av) } - -- | Parse a Haskell module with Haddock comments. This is done in two steps: -- -- * 'parseModuleNoHaddock' to build the AST @@ -4446,10 +4402,6 @@ commentsPA la@(L l a) = do cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -rs :: SrcSpan -> RealSrcSpan -rs (RealSrcSpan l _) = l -rs _ = panic "Parser should only have RealSrcSpan" - hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList hsDoAnn (L l _) (L ll _) kw = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] [] ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1586,7 +1586,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate an overloaded literal mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) -- | Disambiguate a wildcard - mkHsWildCardPV :: SrcSpan -> PV (Located b) + mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b) -- | Disambiguate "a :: t" (type annotation) mkHsTySigPV :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b) @@ -1810,7 +1810,7 @@ instance DisambECP (HsExpr GhcPs) where mkHsOverLitPV (L (EpAnn l an csIn) a) = do cs <- getCommentsFor (locA l) return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) - mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (hsHoleExpr noAnn) mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do cs <- getCommentsFor (locA l) return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig)) @@ -1883,7 +1883,7 @@ instance DisambECP (PatBuilder GhcPs) where cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig anns = do p <- checkLPat b return $ L l (PatBuilderPat (SigPat anns p (mkHsPatSigType noAnn sig))) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63be32711753a83d4d8df82f003088bd84966b85...7cee320fadea91d1b7b9c4e623b1c10b103215a5 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63be32711753a83d4d8df82f003088bd84966b85...7cee320fadea91d1b7b9c4e623b1c10b103215a5 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 Dec 16 19:51:37 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 16 Dec 2023 14:51:37 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Document ghc package's PVP-noncompliance Message-ID: <657dffc9d95c9_e7a73311b9b2c22065f@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - bda87919 by Sylvain Henry at 2023-12-14T14:19:50+01:00 Bump time submodule (#23202) - - - - - 055e9913 by Finley McIlwaine at 2023-12-16T14:51:28-05:00 Late plugins - - - - - 496898fd by Finley McIlwaine at 2023-12-16T14:51:28-05:00 withTiming on LateCCs and late plugins - - - - - 1d616f64 by Finley McIlwaine at 2023-12-16T14:51:28-05:00 add test for late plugins - - - - - 72016b90 by Finley McIlwaine at 2023-12-16T14:51:28-05:00 Document late plugins - - - - - 22 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - compiler/ghc.cabal.in - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - hadrian/src/Rules/Dependencies.hs - libraries/base/tests/all.T - libraries/time - rts/js/time.js - testsuite/driver/testlib.py - testsuite/tests/backpack/cabal/T20509/all.T - testsuite/tests/backpack/cabal/bkpcabal02/all.T - testsuite/tests/backpack/cabal/bkpcabal03/all.T - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/ghc-api/downsweep/all.T - testsuite/tests/numeric/should_run/all.T - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs - testsuite/tests/rts/all.T Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== compiler/ghc.cabal.in ===================================== @@ -20,6 +20,11 @@ Description: . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== hadrian/src/Rules/Dependencies.hs ===================================== @@ -24,16 +24,31 @@ import qualified Text.Parsec as Parsec -- the dependency is implicit. ghc -M should emit this additional dependency but -- until it does we need to add this dependency ourselves. extra_dependencies :: M.Map Package (Stage -> Action [(FilePath, FilePath)]) -extra_dependencies = - M.fromList [(containers, fmap (fmap concat . sequence) (sequence - [dep (containers, "Data.IntSet.Internal") th_internal - ,dep (containers, "Data.Set.Internal") th_internal - ,dep (containers, "Data.Sequence.Internal") th_internal - ,dep (containers, "Data.Graph") th_internal - ])) - ] +extra_dependencies = M.fromList + [ deps containers th_internal + [ "Data.IntSet.Internal" + , "Data.Set.Internal" + , "Data.Sequence.Internal" + , "Data.Graph" + ] + , deps time th_internal + [ "Data.Time.Calendar.CalendarDiffDays" + , "Data.Time.Calendar.WeekDate" + , "Data.Time.Calendar.Quarter" + , "Data.Time.Calendar.Month" + , "Data.Time.Calendar.Week" + , "Data.Time.Calendar.Days" + , "Data.Time.Clock.Internal.UTCTime" + , "Data.Time.Clock.Internal.AbsoluteTime" + , "Data.Time.Clock.Internal.SystemTime" + , "Data.Time.Clock.Internal.DiffTime" + , "Data.Time.Clock.Internal.NominalDiffTime" + , "Data.Time.Clock.Internal.UniversalTime" + ] + ] where + deps pkg to mods = (pkg, fmap (fmap concat . sequence) (sequence (map (\x -> dep (pkg, x) to) mods))) th_internal = (templateHaskell, "Language.Haskell.TH.Lib.Internal") dep (p1, m1) (p2, m2) s = do let context = Context s p1 (error "extra_dependencies: way not set") (error "extra_dependencies: iplace not set") ===================================== libraries/base/tests/all.T ===================================== @@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, ['']) test('listThreads1', omit_ghci, compile_and_run, ['']) test('inits1tails1', normal, compile_and_run, ['']) test('CLC149', normal, compile, ['']) -test('AtomicModifyIORef', normal, compile_and_run, ['']) +test('AtomicModifyIORef', js_fragile(24259), compile_and_run, ['']) test('AtomicSwapIORef', normal, compile_and_run, ['']) test('T23454', normal, compile_fail, ['']) test('T23687', normal, compile_and_run, ['']) ===================================== libraries/time ===================================== @@ -1 +1 @@ -Subproject commit baab563ee2ce547f7b7f7e7069ed09db2d406941 +Subproject commit 97018e7574e561caa74060b115d530a004bd38db ===================================== rts/js/time.js ===================================== @@ -16,5 +16,3 @@ function h$clock_gettime(when, p_d, p_o) { } return 0; } - -function h$CLOCK_REALTIME() { return 0; } ===================================== testsuite/driver/testlib.py ===================================== @@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ): else: return normal; +# expect occasional failures for the JS backend +def js_fragile( bug: IssueNumber ): + if js_arch(): + return fragile(bug); + else: + return normal; + def expect_fail( name, opts ): # The compiler, testdriver, OS or platform is missing a certain # feature, and we don't plan to or can't fix it now or in the ===================================== testsuite/tests/backpack/cabal/T20509/all.T ===================================== @@ -1,6 +1,7 @@ test('T20509', [extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs']) , run_timeout_multiplier(2) + , js_fragile(24259) ], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal02/all.T ===================================== @@ -1,5 +1,6 @@ test('bkpcabal02', [extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']), - normalise_version('bkpcabal01')], + normalise_version('bkpcabal01'), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/backpack/cabal/bkpcabal03/all.T ===================================== @@ -1,4 +1,5 @@ test('bkpcabal03', - [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])], + [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']), + js_fragile(24259)], makefile_test, []) ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'), # times out with ghci test('T4030', omit_ghci, compile_and_run, ['-O']) -test('throwto002', normal, compile_and_run, ['']) +test('throwto002', js_fragile(24259), compile_and_run, ['']) test('throwto003', normal, compile_and_run, ['']) test('mask001', normal, compile_and_run, ['']) ===================================== testsuite/tests/ghc-api/downsweep/all.T ===================================== @@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2))) test('PartialDownsweep', [ extra_run_opts('"' + config.libdir + '"') , ignore_stderr + , js_fragile(24259) ], compile_and_run, ['-package ghc -package exceptions']) ===================================== testsuite/tests/numeric/should_run/all.T ===================================== @@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, ['']) test('T20291', normal, compile_and_run, ['']) test('T22282', normal, compile_and_run, ['']) -test('T22671', normal, compile_and_run, ['']) -test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers']) +test('T22671', js_fragile(24259), compile_and_run, ['']) +test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers']) test('T24066', normal, compile_and_run, ['']) ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 ===================================== testsuite/tests/rts/all.T ===================================== @@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip) , omit_ghci , req_th , when(platform('x86_64-unknown-linux'), fragile(22283)) + , js_fragile(24259) ] , compile_and_run, [config.ghc_th_way_flags]) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31360c805ea46423f3db0f7287bb2d4225f06d5b...72016b90d67e10b841fe89d635739274016c64b6 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31360c805ea46423f3db0f7287bb2d4225f06d5b...72016b90d67e10b841fe89d635739274016c64b6 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 Dec 16 22:32:26 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 16 Dec 2023 17:32:26 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Late plugins Message-ID: <657e257a9e454_e7a73350caf14237540@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 2327796e by Finley McIlwaine at 2023-12-16T17:32:11-05:00 Late plugins - - - - - fe46b05e by Finley McIlwaine at 2023-12-16T17:32:11-05:00 withTiming on LateCCs and late plugins - - - - - 51b4c764 by Finley McIlwaine at 2023-12-16T17:32:11-05:00 add test for late plugins - - - - - 2f5d4452 by Finley McIlwaine at 2023-12-16T17:32:11-05:00 Document late plugins - - - - - 9 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/72016b90d67e10b841fe89d635739274016c64b6...2f5d4452d64b0c407bd9904b787cda8142a37111 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/72016b90d67e10b841fe89d635739274016c64b6...2f5d4452d64b0c407bd9904b787cda8142a37111 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 Dec 17 01:52:37 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sat, 16 Dec 2023 20:52:37 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Late plugins Message-ID: <657e546512ab7_e7a733a06342c25079a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 04e09006 by Finley McIlwaine at 2023-12-16T20:52:28-05:00 Late plugins - - - - - e9501c91 by Finley McIlwaine at 2023-12-16T20:52:28-05:00 withTiming on LateCCs and late plugins - - - - - 47d11fc5 by Finley McIlwaine at 2023-12-16T20:52:29-05:00 add test for late plugins - - - - - 45928a5c by Finley McIlwaine at 2023-12-16T20:52:29-05:00 Document late plugins - - - - - 9 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f5d4452d64b0c407bd9904b787cda8142a37111...45928a5cabdd6e86414e112aa69646c94c65fe03 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2f5d4452d64b0c407bd9904b787cda8142a37111...45928a5cabdd6e86414e112aa69646c94c65fe03 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 Dec 17 06:23:24 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sun, 17 Dec 2023 01:23:24 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Late plugins Message-ID: <657e93dcbbbf9_e7a7340371a002651af@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 874228a7 by Finley McIlwaine at 2023-12-17T01:23:15-05:00 Late plugins - - - - - 19dbb579 by Finley McIlwaine at 2023-12-17T01:23:15-05:00 withTiming on LateCCs and late plugins - - - - - f037cf95 by Finley McIlwaine at 2023-12-17T01:23:15-05:00 add test for late plugins - - - - - 00709bc8 by Finley McIlwaine at 2023-12-17T01:23:15-05:00 Document late plugins - - - - - 9 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45928a5cabdd6e86414e112aa69646c94c65fe03...00709bc8dc9ef5dbcc2463d4e560ffb90e895f58 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45928a5cabdd6e86414e112aa69646c94c65fe03...00709bc8dc9ef5dbcc2463d4e560ffb90e895f58 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 Dec 17 09:57:25 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sun, 17 Dec 2023 04:57:25 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Tackling extra parser allocations stats fail Message-ID: <657ec605d9581_e7a7345221a7427122a@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 70cc5ed9 by Alan Zimmerman at 2023-12-17T09:56:38+00:00 EPA: Tackling extra parser allocations stats fail Step one: make all getCommentsFor results strict. - - - - - 2 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -1447,7 +1447,7 @@ ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs } {% do { hintExplicitForall $1 ; tvbs <- fromSpecTyVarBndrs $2 ; let loc = comb2 $1 $> - ; cs <- getCommentsFor loc + ; !cs <- getCommentsFor loc ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }} | type '=' ktype {% mkTyFamInstEqn (comb2 $1 $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) } @@ -1584,7 +1584,7 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1 ; tvbs <- fromSpecTyVarBndrs $2 ; let loc = comb2 $1 $> - ; cs <- getCommentsFor loc + ; !cs <- getCommentsFor loc ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4)) } } | context '=>' type {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) } @@ -1825,7 +1825,7 @@ binds :: { Located (HsLocalBinds GhcPs) } -- May have implicit parameters -- No type declarations : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) - ; cs <- getCommentsFor (gl $1) + ; !cs <- getCommentsFor (gl $1) ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc @@ -2553,7 +2553,7 @@ decl_no_th :: { LHsDecl GhcPs } -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] - ; cs <- getCommentsFor l + ; !cs <- getCommentsFor l ; return $! (sL (commentsA l cs) $ ValD noExtField r) } } | PREFIX_PERCENT atype infixexp opt_sig rhs {% runPV (unECP $3) >>= \ $3 -> do { let { l = comb2 $3 $> } @@ -2564,7 +2564,7 @@ decl_no_th :: { LHsDecl GhcPs } -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] - ; cs <- getCommentsFor l + ; !cs <- getCommentsFor l ; return $! (sL (commentsA l cs) $ ValD noExtField r) } } | pattern_synonym_decl { $1 } @@ -4304,7 +4304,7 @@ n2l (L la a) = L (l2l la) a acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) acsFinal a = do let (L l _) = a emptyComments Nothing - cs <- getCommentsFor l + !cs <- getCommentsFor l csf <- getFinalCommentsFor l meof <- getEofPos let ce = case meof of @@ -4314,37 +4314,37 @@ acsFinal a = do acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a) acs l a = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return (a l cs) acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a) acsA l a = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return $ reLoc (a l cs) ams1 :: MonadP m => Located a -> b -> m (LocatedA b) ams1 (L l a) b = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) b) amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a) amsA' (L l a) = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) a) amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) amsA (L l a) bs = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return (L (addAnnsA l bs cs) a) amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a) amsAl (L l a) loc bs = do - cs <- getCommentsFor loc + !cs <- getCommentsFor loc return (L (addAnnsA l bs cs) a) amsr :: MonadP m => Located a -> an -> m (LocatedAn an a) amsr (L l a) an = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) an cs) a) -- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose @@ -4463,7 +4463,7 @@ addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span)) addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) addTrailingAnnL (L anns a) ta = do - cs <- getCommentsFor (locA anns) + !cs <- getCommentsFor (locA anns) let anns' = addTrailingAnnToL ta cs anns return (L anns' a) ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -392,7 +392,7 @@ mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs) -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do - cs <- getCommentsFor (locA loc) + !cs <- getCommentsFor (locA loc) return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do @@ -400,7 +400,7 @@ mkSpliceDecl lexpr@(L loc expr) return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) | otherwise = do - cs <- getCommentsFor (locA loc) + !cs <- getCommentsFor (locA loc) return $ L (addCommentsToEpAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc (HsUntypedSpliceExpr noAnn lexpr)) BareSplice) @@ -412,7 +412,7 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles anns = do { roles' <- mapM parse_role roles - ; cs <- getCommentsFor loc + ; !cs <- getCommentsFor loc ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs) $ RoleAnnotDecl anns tycon roles' } where @@ -1677,12 +1677,12 @@ instance DisambECP (HsCmd GhcPs) where mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid mkHsLamPV l lam_variant (L lm m) anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg) mkHsLetPV l tkLet bs tkIn e = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs @@ -1691,11 +1691,11 @@ instance DisambECP (HsCmd GhcPs) where mkHsOpAppPV l c1 op c2 = do let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2] mkHsCasePV l c (L lm m) anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l let mg = mkMatchGroup FromSource (L lm m) return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg) @@ -1708,14 +1708,14 @@ instance DisambECP (HsCmd GhcPs) where mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) mkHsDoPV l Nothing stmts anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo anns stmts) mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) @@ -1762,29 +1762,29 @@ instance DisambECP (HsExpr GhcPs) where return (L l (hsHoleExpr noAnn)) ecpFromExp' = return mkHsProjUpdatePV l fields arg isPun anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns mkHsLetPV l tkLet bs tkIn c = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l e1 op e2 = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp [] e1 (reLoc op) e2 mkHsCasePV l e (L lm m) anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l let mg = mkMatchGroup FromSource (L lm m) return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg) mkHsLamPV l lam_variant (L lm m) anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) checkLamMatchGroup l lam_variant mg return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg) type FunArg (HsExpr GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l@(EpAnn anc an csIn) e1 e2 = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) checkExpBlockArguments e1 checkExpBlockArguments e2 return $ L (EpAnn anc an (csIn Semi.<> cs)) (HsApp noExtField e1 e2) @@ -1793,42 +1793,42 @@ instance DisambECP (HsExpr GhcPs) where return $ L l (HsAppType at e (mkHsWildCardBndrs t)) mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) mkHsDoPV l mod stmts anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo anns (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do - cs <- getCommentsFor (getHasLoc l) + !cs <- getCommentsFor (getHasLoc l) return $ L (EpAnn anc noAnn cs) (HsVar noExtField v) mkHsLitPV (L l a) = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a) mkHsOverLitPV (L (EpAnn l an csIn) a) = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (hsHoleExpr noAnn) mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig)) mkHsExplicitListPV l xs anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs) mkHsSplicePV (L l a) = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a) mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) mkHsNegAppPV l a anns = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr) mkHsSectionR_PV l op e = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e) mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) @@ -1861,7 +1861,7 @@ instance DisambECP (PatBuilder GhcPs) where type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 [] mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant) @@ -1871,7 +1871,7 @@ instance DisambECP (PatBuilder GhcPs) where superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) mkHsAppTypePV l p at t = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs return $ L l (PatBuilderAppType p at (mkHsTyPat anns t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat @@ -1880,7 +1880,7 @@ instance DisambECP (PatBuilder GhcPs) where mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedLitPat lit - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField)) @@ -1889,41 +1889,41 @@ instance DisambECP (PatBuilder GhcPs) where return $ L l (PatBuilderPat (SigPat anns p (mkHsPatSigType noAnn sig))) mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs - cs <- getCommentsFor l + !cs <- getCommentsFor l return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps))) mkHsSplicePV (L l sp) = do - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid else do - cs <- getCommentsFor l + !cs <- getCommentsFor l r <- mkPatRec a (mk_rec_fields fs ddLoc) anns checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) mkHsNegAppPV l (L lp p) anns = do lit <- case p of PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) _ -> patFail l $ PsErrInPat p PEIP_NegApp - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns)) mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) mkHsViewPatPV l a b anns = do p <- checkLPat b - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat anns a p)) mkHsAsPatPV l v at e = do p <- checkLPat e - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p)) mkHsLazyPatPV l e a = do p <- checkLPat e - cs <- getCommentsFor l + !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p)) mkHsBangPatPV l e an = do p <- checkLPat e - cs <- getCommentsFor l + !cs <- getCommentsFor l let pb = BangPat an p hintBangPat l pb return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb) @@ -2834,8 +2834,6 @@ data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) mkModuleImpExp warning anns (L l specname) subs = do - -- cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments - -- let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) @@ -3108,7 +3106,7 @@ mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) -- Tuple mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity) where toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs @@ -3123,7 +3121,7 @@ mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) a [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] -> AnnExplicitSum o barsp barsa c _ -> panic "mkSumOrTupleExpr" - cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (locA l) return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e) mkSumOrTupleExpr l Boxed a at Sum{} _ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70cc5ed94e646da996a4375c942a72bc8a8f5d60 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/70cc5ed94e646da996a4375c942a72bc8a8f5d60 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 Dec 17 10:33:42 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Sun, 17 Dec 2023 05:33:42 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Late plugins Message-ID: <657ece8628c24_e7a7345e5bcf427609e@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 49ed33d3 by Finley McIlwaine at 2023-12-17T05:33:33-05:00 Late plugins - - - - - dcf217ff by Finley McIlwaine at 2023-12-17T05:33:33-05:00 withTiming on LateCCs and late plugins - - - - - 7e1a4610 by Finley McIlwaine at 2023-12-17T05:33:33-05:00 add test for late plugins - - - - - 88346e19 by Finley McIlwaine at 2023-12-17T05:33:33-05:00 Document late plugins - - - - - 9 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00709bc8dc9ef5dbcc2463d4e560ffb90e895f58...88346e1951317ac6f712ea7bb50424e835c52195 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/00709bc8dc9ef5dbcc2463d4e560ffb90e895f58...88346e1951317ac6f712ea7bb50424e835c52195 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 Dec 17 11:18:37 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sun, 17 Dec 2023 06:18:37 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Tackling extra parser allocations stats fail #2 Message-ID: <657ed90dec11b_e7a734727995c2810fc@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: 37ac8434 by Alan Zimmerman at 2023-12-17T11:18:15+00:00 EPA: Tackling extra parser allocations stats fail #2 Adding `seq` to various Parser.y helper functions - - - - - 1 changed file: - compiler/GHC/Parser.y Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -4100,32 +4100,32 @@ sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} sL1 :: HasLoc a => a -> b -> Located b -sL1 x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1) +sL1 x = x `seq` sL (getHasLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sL1a #-} sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b -sL1a x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) +sL1a x = x `seq` sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sL1n #-} sL1n :: HasLoc a => a -> b -> LocatedN b -sL1n x = L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) +sL1n x = x `seq` L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c -sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) +sLL x y = x `seq` y `seq` sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {-# INLINE sLLa #-} sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c -sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) +sLLa x y = x `seq` y `seq` sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) {-# INLINE sLLl #-} sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c -sLLl x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) +sLLl x y = x `seq` y `seq` sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) {-# INLINE sLLAsl #-} sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c sLLAsl [] = sL1 -sLLAsl (x:_) = sLL x +sLLAsl (x:_) = x `seq` sLL x {- Note [Adding location info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4244,35 +4244,35 @@ in GHC.Parser.Annotation -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself mj :: AnnKeywordId -> Located e -> AddEpAnn -mj a l = AddEpAnn a (srcSpan2e $ gl l) +mj a l = a `seq` l `seq` AddEpAnn a (srcSpan2e $ gl l) mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn -mjN a l = AddEpAnn a (srcSpan2e $ glA l) +mjN a l = a `seq` l `seq` AddEpAnn a (srcSpan2e $ glA l) -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself, provided the span is not zero width mz :: AnnKeywordId -> Located e -> [AddEpAnn] -mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)] +mz a l = a `seq` l `seq` if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)] msemi :: Located e -> [TrailingAnn] -msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)] +msemi l = l `seq` if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)] msemiA :: Located e -> [AddEpAnn] -msemiA l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)] +msemiA l = l `seq` if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)] msemim :: Located e -> Maybe EpaLocation -msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l) +msemim l = l `seq` if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l) -- |Construct an AddEpAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddEpAnn -mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l) +mu a lt@(L l t) = a `seq` lt `seq` AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId -toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a +toUnicodeAnn a t = a `seq` t `seq` if isUnicode t then unicodeAnn a else a toUnicode :: Located Token -> IsUnicodeSyntax toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax @@ -4286,19 +4286,19 @@ glA :: HasLoc a => a -> SrcSpan glA = getHasLoc glR :: HasLoc a => a -> Anchor -glR la = EpaSpan (getHasLoc la) +glR la = la `seq` EpaSpan (getHasLoc la) glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor -glEE x y = spanAsAnchor $ comb2 x y +glEE x y = x `seq` y `seq` spanAsAnchor $ comb2 x y glRM :: Located a -> Maybe Anchor -glRM (L l _) = Just $ spanAsAnchor l +glRM (L l _) = l `seq` Just $ spanAsAnchor l glAA :: HasLoc a => a -> EpaLocation glAA = srcSpan2e . getHasLoc n2l :: LocatedN a -> LocatedA a -n2l (L la a) = L (l2l la) a +n2l (L la a) = la `seq` a `seq` L (l2l la) a -- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) @@ -4314,12 +4314,12 @@ acsFinal a = do acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a) acs l a = do - !cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (l `seq` locA l) return (a l cs) acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a) acsA l a = do - !cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (l `seq` locA l) return $ reLoc (a l cs) ams1 :: MonadP m => Located a -> b -> m (LocatedA b) @@ -4334,7 +4334,7 @@ amsA' (L l a) = do amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) amsA (L l a) bs = do - !cs <- getCommentsFor (locA l) + !cs <- getCommentsFor (l `seq` locA l) return (L (addAnnsA l bs cs) a) amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a) @@ -4349,24 +4349,24 @@ amsr (L l a) an = do -- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddEpAnn -mo ll = mj AnnOpen ll -mc ll = mj AnnClose ll +mo ll = ll `seq` mj AnnOpen ll +mc ll = ll `seq` mj AnnClose ll moc,mcc :: Located Token -> AddEpAnn -moc ll = mj AnnOpenC ll -mcc ll = mj AnnCloseC ll +moc ll = ll `seq` mj AnnOpenC ll +mcc ll = ll `seq` mj AnnCloseC ll mop,mcp :: Located Token -> AddEpAnn -mop ll = mj AnnOpenP ll -mcp ll = mj AnnCloseP ll +mop ll = ll `seq` mj AnnOpenP ll +mcp ll = ll `seq` mj AnnCloseP ll moh,mch :: Located Token -> AddEpAnn -moh ll = mj AnnOpenPH ll -mch ll = mj AnnClosePH ll +moh ll = ll `seq` mj AnnOpenPH ll +mch ll = ll `seq` mj AnnClosePH ll mos,mcs :: Located Token -> AddEpAnn -mos ll = mj AnnOpenS ll -mcs ll = mj AnnCloseS ll +mos ll = ll `seq` mj AnnOpenS ll +mcs ll = ll `seq` mj AnnCloseS ll -- | Parse a Haskell module with Haddock comments. This is done in two steps: -- @@ -4399,7 +4399,7 @@ commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs -- between top level declarations. commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a) commentsPA la@(L l a) = do - cs <- getPriorCommentsFor (getLocA la) + !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList @@ -4418,15 +4418,15 @@ listAsAnchorM (L l _:_) = _ -> Nothing epTok :: Located Token -> EpToken tok -epTok (L l _) = EpTok (EpaSpan l) +epTok (L l _) = l `seq` EpTok (EpaSpan l) epUniTok :: Located Token -> EpUniToken tok utok -epUniTok t@(L l _) = EpUniTok (EpaSpan l) u +epUniTok t@(L l _) = t `seq` l `seq` EpUniTok (EpaSpan l) u where u = if isUnicode t then UnicodeSyntax else NormalSyntax epExplicitBraces :: Located Token -> Located Token -> EpLayout -epExplicitBraces t1 t2 = EpExplicitBraces (epTok t1) (epTok t2) +epExplicitBraces t1 t2 = t1 `seq` t2 `seq` EpExplicitBraces (epTok t1) (epTok t2) -- ------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ac8434a4fef69f7678d54d97e9c79dd9d0b2fa -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/37ac8434a4fef69f7678d54d97e9c79dd9d0b2fa 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 Dec 17 16:05:38 2023 From: gitlab at gitlab.haskell.org (Alan Zimmerman (@alanz)) Date: Sun, 17 Dec 2023 11:05:38 -0500 Subject: [Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: parser allocations #3 Message-ID: <657f1c5222f49_e7a734da1eeb8295135@gitlab.mail> Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC Commits: bd619edd by Alan Zimmerman at 2023-12-17T16:05:20+00:00 EPA: parser allocations #3 The increase is from HsAppTy`, force the arguments to its constructor. - - - - - 1 changed file: - compiler/GHC/Parser/PostProcess.hs Changes: ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1999,7 +1999,7 @@ class DisambTD b where instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return - mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) + mkHsAppTyPV t1 t2 = return (mkHsAppTy (t1 `seq` t2 `seq` t1) t2) mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2) mkUnpackednessPV = addUnpackednessP View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd619edd1ca8a49c7fc2c4478c0c47ca496d0fc2 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bd619edd1ca8a49c7fc2c4478c0c47ca496d0fc2 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 Dec 18 08:27:33 2023 From: gitlab at gitlab.haskell.org (Sebastian Graf (@sgraf812)) Date: Mon, 18 Dec 2023 03:27:33 -0500 Subject: [Git][ghc/ghc][wip/T24124] Make `seq#` a magic Id and inline it in CorePrep (#24124) Message-ID: <658002759bfd8_e7a7363fb9718322174@gitlab.mail> Sebastian Graf pushed to branch wip/T24124 at Glasgow Haskell Compiler / GHC Commits: e128b9a5 by Sebastian Graf at 2023-12-18T09:27:05+01:00 Make `seq#` a magic Id and inline it in CorePrep (#24124) We can save much code and explanation in Tag Inference and StgToCmm by giving `seq#` a definition as a Magic Id in `GHC.Magic` and inline this definition in CorePrep. See the updated `Note [seq# magic]`. I also implemented a new `Note [Flatten case-bind]` to get better code for otherwise nested case scrutinees. I renamed the contructors of `ArgInfo` to use an `AI` prefix in order to resolve the clash between `type CpeApp = CoreExpr` and the data constructor of `ArgInfo`, as well as fixed typos in `Note [CorePrep invariants]`. Fixes #24252 and #24124. - - - - - 20 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Stg/InferTags.hs - compiler/GHC/Stg/InferTags/Rewrite.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/StgToJS/Utils.hs - compiler/GHC/Types/Id/Make.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-prim/GHC/Magic.hs - + testsuite/tests/core-to-stg/T24124.hs - + testsuite/tests/core-to-stg/T24124.stderr - testsuite/tests/core-to-stg/all.T - testsuite/tests/simplStg/should_compile/T15226b.stderr Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -2340,7 +2340,7 @@ rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashIdKey :: Unique thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2375,6 +2375,8 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: Unique rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 +seqHashIdKey = mkPreludeMiscIdUnique 134 + coerceKey :: Unique coerceKey = mkPreludeMiscIdUnique 157 ===================================== compiler/GHC/Builtin/PrimOps.hs ===================================== @@ -916,10 +916,9 @@ instance Outputable PrimCall where = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False DataToTagOp -> False p -> not (primOpOutOfLine p) ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -3640,13 +3640,6 @@ primop SparkOp "spark#" GenPrimOp with effect = ReadWriteEffect code_size = { primOpCodeSizeForeignCall } --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - with - effect = ThrowsException - work_free = True -- seq# does work iff its lifted arg does work - primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Id.Make ( unboxedUnitExpr ) +import GHC.Types.Id.Make ( unboxedUnitExpr, seqHashIdName ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -821,7 +821,6 @@ primOpRules nm = \case AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -2038,7 +2037,7 @@ unsafeEqualityProofRule {- Note [seq# magic] ~~~~~~~~~~~~~~~~~~~~ -The primop +The magic Id (See Note [magicIds]) seq# :: forall a s . a -> State# s -> (# State# s, a #) is /not/ the same as the Prelude function seq :: a -> b -> b @@ -2048,46 +2047,115 @@ mechanism for 'evaluate' evaluate :: a -> IO a evaluate a = IO $ \s -> seq# a s -The semantics of seq# is +Its (NOINLINE) definition in GHC.Magic is simply + seq# a s = a `seq` (# s, a #), +but the precise semantics of seq# exported to the user is + * wait for all earlier actions in the State#-token-thread to complete * evaluate its first argument * and return it Things to note -* Why do we need a primop at all? That is, instead of +(SEQ1) + Clearly, the definition given above satisfies the precise semantics, + but why is it NOINLINE? That is, instead of case seq# x s of (# x, s #) -> blah why not instead say this? case x of { DEFAULT -> blah } - Reason (see #5129): if we saw + One reason (see #5129): if we saw catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler then we'd drop the 'case x' because the body of the case is bottom - anyway. But we don't want to do that; the whole /point/ of + anyway (we revisit this decision in #24251). + But we don't want to do that; the whole /point/ of seq#/evaluate is to evaluate 'x' first in the IO monad. In short, we /always/ evaluate the first argument and never just discard it. -* Why return the value? So that we can control sharing of seq'd + However, we *do* inline saturated applications of `seq#` in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need `seq#` to be known-key. + +(SEQ2) + `seq#` is intended to mean "evaluate this argument now -- not earlier". + Therefore, we must not only NOINLINE `seq#`, we must also take care that + we do /not/ expose Demand Analysis to its strict demand signature <1L>. + because then it would feel free to rearrange evaluation order, lest we lose + out on important unboxing opportunities, such as in + + foo :: Bool -> Bool -> (Int, Int) -> Int + foo True _ (a,b) = a + b + foo _ False (a,b) = 1 + a + b + + 'foo' is strict in the pair and its components and we *absolutely* want to + unbox it. However, doing so is impossible without affecting evaluation order: + Without optimisation, `bar False (error "OK") (error "Not OK")` errors "OK". + If we decide to unbox (a,b) and insert an eval on the first (strict) arg in + the wrapper as well, we get "Not OK". + + More generally, preserving evaluation order is fundamentally at odds + with exploiting the results of Strictness Analysis, and the latter offers + huge leverage throughout the compiler. + + More concretely, consider + do { evaluate x; evaluate y } + Operationally, this should evaluate `x` and then `y`. + If `seq#` was visibly strict, they might be evaluated in the opposite order. + Setting its signature to is easily achieved in GHC.Types.Id.Make. + +(SEQ3) + Mainly for reasons of backwards compatibility, we recognise `seq#` during + Demand Analysis as not throwing a precise exception by the mechanism + implementing Note [Precise exceptions and strictness analysis]. + More concretely, + f :: Int -> Int -> IO Int + f x y = evaluate x >> pure $! y+1 + used to be strict in `y` and thus unboxed, and changing that would break + the performance of client code. We retain the old behavior by treating + `seq#` just like any PrimOp except `raiseIO#`. + +(SEQ4) + Why return the value? So that we can control sharing of seq'd values: in let x = e in x `seq` ... x ... We don't want to inline x, so better to represent it as let x = e in case seq# x RW of (# _, x' #) -> ... x' ... also it matches the type of rseq in the Eval monad. -Implementing seq#. The compiler has magic for SeqOp in +Implementing seq#. The compiler has magic for `seq#` in -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) +- GHC.Types.Id.Make: Wire in `seq#`, set IdInfo (demand signature, cf. (SEQ2)) -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# +- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - Simplify.addEvals records evaluated-ness for the result; see Note [Adding evaluatedness info to pattern-bound variables] in GHC.Core.Opt.Simplify.Iteration -- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a - properly-tagged pointer inside of its unboxed-tuple result. +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: return False for seq#. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + We are only inlining `seq#`, leaving opportunities for case-of-known-con + behind that are easily picked up by Unarise: + + case seq# f 13 s of (# s', r #) -> rhs + ==> {Prep} + case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs + ==> {Unarise} + case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r] + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. -} seqRule :: RuleM CoreExpr @@ -2177,7 +2245,9 @@ builtinRules platform <- getPlatform return $ Var (primOpId IntAndOp) `App` arg `App` mkIntVal platform (d - 1) - ] + ], + + mkBasicRule seqHashIdName 4 seqRule ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) import GHC.Core.Opt.WorkWrap.Utils +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -602,16 +603,21 @@ exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool exprMayThrowPreciseException envs e | not (forcesRealWorld envs (exprType e)) = False -- 1. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just op <- isPrimOpId_maybe f , op /= RaiseIOOp = False -- 2. in the Note - | (Var f, _) <- collectArgs e + | Var f <- fn , Just fcall <- isFCallId_maybe f , not (isSafeForeignCall fcall) = False -- 3. in the Note + | Var f <- fn + , f `hasKey` seqHashIdKey + = False -- 3. in the Note | otherwise = True -- _. in the Note + where + (fn, _) = collectArgs e -- | Recognises types that are -- * @State# RealWorld@ @@ -799,14 +805,16 @@ For an expression @f a1 ... an :: ty@ we determine that (Why not simply unboxed pairs as above? This is motivated by T13380{d,e}.) 2. False If f is a PrimOp, and it is *not* raiseIO# - 3. False If f is an unsafe FFI call ('PlayRisky') + 3. False If f is the PrimOp-like `seq#`, cf. Note [seq# magic]. + 4. False If f is an unsafe FFI call ('PlayRisky') _. True Otherwise "give up". It is sound to return False in those cases, because 1. We don't give any guarantees for unsafePerformIO, so no precise exceptions from pure code. 2. raiseIO# is the only primop that may throw a precise exception. - 3. Unsafe FFI calls may not interact with the RTS (to throw, for example). + 3. `seq# = \(!a) s -> (# a, s #)`, so it does not throw a precise exception. + 4. Unsafe FFI calls may not interact with the RTS (to throw, for example). See haddock on GHC.Types.ForeignCall.PlayRisky. We *need* to return False in those cases, because @@ -814,7 +822,8 @@ We *need* to return False in those cases, because 2. We would lose strictness for primops like getMaskingState#, which introduces a substantial regression in GHC.IO.Handle.Internals.wantReadableHandle. - 3. We would lose strictness for code like GHC.Fingerprint.fingerprintData, + 3. `seq#` used to be a PrimOp and we want to stay backwards compatible. + 4. We would lose strictness for code like GHC.Fingerprint.fingerprintData, where an intermittent FFI call to c_MD5Init would otherwise lose strictness on the arguments len and buf, leading to regressions in T9203 (2%) and i386's haddock.base (5%). Tested by T13380f. ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -60,9 +60,8 @@ import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) +import GHC.Builtin.Names( runRWKey, seqHashIdKey ) import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) import GHC.Data.FastString @@ -3370,7 +3369,7 @@ addEvals scrut con vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately. , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f + , f `hasKey` seqHashIdKey , let x' = zapIdOccInfoAndSetEvald MarkedStrict x = [s, x'] ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -157,19 +157,19 @@ Note [CorePrep invariants] Here is the syntax of the Core produced by CorePrep: Trivial expressions - arg ::= lit | var - | arg ty | /\a. arg - | truv co | /\c. arg | arg |> co + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co Applications - app ::= lit | var | app arg | app ty | app co | app |> co + app ::= lit | var | app arg | app ty | app co | app |> co Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only - | case app of pat -> body - | /\a. body | /\c. body - | body |> co + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body @@ -304,6 +304,13 @@ There are 3 main categories of floats, encoded in the `FloatingBind` type: bind the unsafe coercion field of the Refl constructor. * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep]. +It is quite essential that CorePrep *does not* rearrange the order in which +evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers +the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does +not attempt to reorder the telescope of Floats or float out out of non-floated +binding sites (such as Case alts) in the first place; for that it would have to +do some kind of data dependency analysis. + Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -594,7 +601,7 @@ cpeBind top_lvl env (NonRec bndr rhs) | otherwise = snocFloat floats new_float - new_float = mkNonRecFloat env dmd is_unlifted bndr1 rhs1 + new_float = mkNonRecFloat env is_unlifted bndr1 rhs1 ; return (env2, floats1, Nothing) } @@ -647,7 +654,7 @@ cpeBind top_lvl env (Rec pairs) -- group into a single giant Rec add_float (Float bind bound _) prs2 | bound /= CaseBound - || all (definitelyLiftedType . idType) (bindersOf bind) + || all (not . isUnliftedType . idType) (bindersOf bind) -- The latter check is hit in -O0 (i.e., flavours quick, devel2) -- for dictionary args which haven't been floated out yet, #24102. -- They are preferably CaseBound, but since they are lifted we may @@ -679,7 +686,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkNonRecFloat env topDmd False v rhs2 + ; let float = mkNonRecFloat env False v rhs2 ; return ( snocFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -842,13 +849,23 @@ cpeRhsE env (Case scrut bndr ty alts) ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' | cp_catchNonexhaustiveCases $ cpe_config env + -- Suppose the alternatives do not cover all the data constructors of the type. + -- That may be fine: perhaps an earlier case has dealt with the missing cases. + -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag + -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases + -- (This alternative will only be taken if there is a bug in GHC.) , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' - ; return (floats, Case scrut' bndr2 ty alts'') } + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let is_unlifted = isUnliftedType (idType bndr2) + , let float = mkCaseFloat is_unlifted bndr2 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr2 ty alts'') } where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs @@ -937,14 +954,14 @@ and it's extra work. -- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick CoreTickish +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish instance Outputable ArgInfo where - ppr (CpeApp arg) = text "app" <+> ppr arg - ppr (CpeCast co) = text "cast" <+> ppr co - ppr (CpeTick tick) = text "tick" <+> ppr tick + ppr (AIApp arg) = text "app" <+> ppr arg + ppr (AICast co) = text "cast" <+> ppr co + ppr (AITick tick) = text "tick" <+> ppr tick {- Note [Ticks and mandatory eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -986,7 +1003,7 @@ cpe_app filters out the tick as a underscoped tick on the expression body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. -} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops +-- May return a CpeRhs (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1005,9 +1022,9 @@ cpeApp top_env expr collect_args e = go e [] where go (App fun arg) as - = go fun (CpeApp arg : as) + = go fun (AIApp arg : as) go (Cast fun co) as - = go fun (CpeCast co : as) + = go fun (AICast co : as) go (Tick tickish fun) as -- Profiling ticks are slightly less strict so we expand their scope -- if they cover partial applications of things like primOps. @@ -1020,7 +1037,7 @@ cpeApp top_env expr , etaExpansionTick head' tickish = (head,as') where - (head,as') = go fun (CpeTick tickish : as) + (head,as') = go fun (AITick tickish : as) -- Terminal could still be an app if it's wrapped by a tick. -- E.g. Tick (f x) can give us (f x) as terminal. @@ -1030,7 +1047,7 @@ cpeApp top_env expr -> CoreExpr -- The thing we are calling -> [ArgInfo] -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) + cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey @@ -1056,24 +1073,38 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) + cpe_app env (Var f) (AIApp _runtimeRep at Type{} : AIApp _type at Type{} : AIApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , has_value_arg (CpeApp arg : rest) + , has_value_arg (AIApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) + _ -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest) -- TODO: What about casts? where has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) + has_value_arg (AIApp arg:_rest) | not (isTyCoArg arg) = True has_value_arg (_:rest) = has_value_arg rest + -- See Note [seq# magic]. This is step (1) for CorePrep + cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty at Type{}, AIApp thing, AIApp token] + | f `hasKey` seqHashIdKey + -- seq# thing token ==> case thing of res { __DEFAULT -> (# token, res#) }, + -- allocating a Float for (case thing of res { __DEFAULT -> _ }) + -- and turning token into a CpeArg as needed + = do { (floats1, thing) <- cpeBody env thing + ; (floats2, token) <- cpeArg env topDmd token + ; case_bndr <- newVar ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let is_unlifted = False -- otherwise seq# would not type-check + ; let float = mkCaseFloat is_unlifted case_bndr thing + ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) } + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 @@ -1120,13 +1151,13 @@ cpeApp top_env expr go [] !n = n go (info:infos) n = case info of - CpeCast {} -> go infos n - CpeTick tickish + AICast {} -> go infos n + AITick tickish | tickishFloatable tickish -> go infos n -- If we can't guarantee a tick will be floated out of the application -- we can't guarantee the value args following it will be applied. | otherwise -> n - CpeApp e -> go infos n' + AIApp e -> go infos n' where !n' | isTypeArg e = n @@ -1182,13 +1213,13 @@ cpeApp top_env expr let tick_fun = foldr mkTick fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - CpeApp (Type arg_ty) + AIApp (Type arg_ty) -> rebuild_app' env as (App fun' (Type arg_ty)) floats ss rt_ticks req_depth - CpeApp (Coercion co) + AIApp (Coercion co) -> rebuild_app' env as (App fun' (Coercion co)) floats (drop 1 ss) rt_ticks req_depth - CpeApp arg -> do + AIApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) @@ -1197,10 +1228,10 @@ cpeApp top_env expr (fs, arg') <- cpeArg top_env ss1 arg rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) - CpeCast co + AICast co -> rebuild_app' env as (Cast fun' co) floats ss rt_ticks req_depth -- See Note [Ticks and mandatory eta expansion] - CpeTick tickish + AITick tickish | tickishPlace tickish == PlaceRuntime , req_depth > 0 -> assert (isProfTick tickish) $ @@ -1481,10 +1512,11 @@ cpeArg env dmd arg -- see Note [ANF-ising literal string arguments] ; if exprIsTrivial arg2 then return (floats2, arg2) - else do { v <- newVar arg_ty - -- See Note [Eta expansion of arguments in CorePrep] + else do { v <- (`setIdDemandInfo` dmd) <$> newVar arg_ty + -- See Note [Pin demand info on floats] ; let arg3 = cpeEtaExpandArg env arg2 - arg_float = mkNonRecFloat env dmd is_unlifted v arg3 + -- See Note [Eta expansion of arguments in CorePrep] + ; let arg_float = mkNonRecFloat env is_unlifted v arg3 ; return (snocFloat floats2 arg_float, varToCoreExpr v) } } @@ -1703,6 +1735,51 @@ cpeEtaExpand arity expr Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks. +For example, + f (g x) +where `f` uses its argument at least once, creates a Float for `y = g x` and we +should better pin appropriate demand info on `y`. + +Note [Flatten case-binds] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have the following call, where f is strict: + f (case x of DEFAULT -> blah) +(For the moment, ignore the fact that the Simplifier will have floated that +`case` out because `f` is strict.) +In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind` + + Float (a = case x of y { DEFAULT -> blah }) CaseBound top_lvl + +with the call `f a`. When we wrap that `Float` we will get + + case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a } + +which is a bit silly. Actually the rest of the back end can cope with nested +cases like this, but it is harder to read and we'd prefer the more direct: + + case x of y { DEFAULT -> + case blah of a { DEFAULT -> f a }} + +This is easy to avoid: turn that + + case x of DEFAULT -> blah + +into a FloatingBind of its own. This is easily done in the Case +equation for `cpsRhsE`. Then our example will generate /two/ floats: + + Float (y = x) CaseBound top_lvl + Float (a = blah) CaseBound top_lvl + +and we'll end up with nested cases. + +Of course, the Simplifier never leaves us with an argument like this, but we +/can/ see + + data T a = T !a + ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs + +and the above footwork in cpsRhsE avoids generating a nested case. + Note [Speculative evaluation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1816,6 +1893,9 @@ The `FloatInfo` of a `Float` describes how far it can float without * Any binding is at least `StrictContextFloatable`, meaning we may float it out of a strict context such as `f <>` where `f` is strict. + We may never float out of a Case alternative `case e of p -> <>`, though, + even if we made sure that `p` does not capture any variables of the float, + because that risks sequencing guarantees of Note [seq# magic]. * A binding is `LazyContextFloatable` if we may float it out of a lazy context such as `let x = <> in Just x`. @@ -1982,19 +2062,38 @@ zipFloats = appFloats zipManyFloats :: [Floats] -> Floats zipManyFloats = foldr zipFloats emptyFloats -mkNonRecFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ - Float (NonRec bndr' rhs) bound info +mkCaseFloat :: Bool -> Id -> CpeRhs -> FloatingBind +mkCaseFloat is_unlifted bndr scrut = Float (NonRec bndr scrut) bound info + where + (bound, info) +{- +Eventually we want the following code, when #20749 is fixed. +Unfortunately, today it breaks T24124. + | is_lifted, is_hnf = (LetBound, TopLvlFloatable) + -- `seq# (case x of x' { __DEFAULT -> StrictBox x' }) s` should + -- let-bind `StrictBox x'` after Note [Flatten case-binds]. +-} + | exprIsTickedString scrut = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | otherwise = (CaseBound, StrictContextFloatable) + -- For a Case, we never want to drop the eval; hence no need to test + -- for ok-for-spec-eval + _is_lifted = not is_unlifted + _is_hnf = exprIsHNF scrut + +mkNonRecFloat :: CorePrepEnv -> Bool -> Id -> CpeRhs -> FloatingBind +mkNonRecFloat env is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr $ + Float (NonRec bndr rhs) bound info where - bndr' = setIdDemandInfo bndr dmd -- See Note [Pin demand info on floats] - (bound,info) + (bound, info) | is_lifted, is_hnf = (LetBound, TopLvlFloatable) -- is_lifted: We currently don't allow unlifted values at the -- top-level or inside letrecs -- (but SG thinks that in principle, we should) | is_data_con bndr = (LetBound, TopLvlFloatable) - -- We need this special case for unlifted DataCon workers/wrappers - -- until #17521 is fixed + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level @@ -2012,6 +2111,7 @@ mkNonRecFloat env dmd is_unlifted bndr rhs = -- pprTraceWith "mkNonRecFloat" ppr is_lifted = not is_unlifted is_hnf = exprIsHNF rhs + dmd = idDemandInfo bndr is_strict = isStrUsedDmd dmd ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs is_rec_call = (`elemUnVarSet` cpe_rec_ids env) @@ -2044,7 +2144,7 @@ deFloatTop floats where get (Float b _ TopLvlFloatable) bs = get_bind b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "deFloatTop" (ppr b) -- See Note [Dead code in CorePrep] get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) ===================================== compiler/GHC/Stg/InferTags.hs ===================================== @@ -19,7 +19,6 @@ import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) -import GHC.Builtin.PrimOps ( PrimOp(..) ) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) @@ -333,21 +332,10 @@ inferTagExpr env (StgTick tick body) (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) - | StgPrimOp SeqOp <- op - -- Recall seq# :: a -> State# s -> (# State# s, a #) - -- However the output State# token has been unarised away, - -- so we now effectively have - -- seq# :: a -> State# s -> (# a #) - -- The key point is the result of `seq#` is guaranteed evaluated and properly - -- tagged (because that result comes directly from evaluating the arg), - -- and we want tag inference to reflect that knowledge (#15226). - -- Hence `TagTuple [TagProper]`. - -- See Note [seq# magic] in GHC.Core.Opt.ConstantFold - = (TagTuple [TagProper], StgOpApp op args ty) - -- Do any other primops guarantee to return a properly tagged value? - -- Probably not, and that is the conservative assumption anyway. + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) - | otherwise = (TagDunno, StgOpApp op args ty) + = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') ===================================== compiler/GHC/Stg/InferTags/Rewrite.hs ===================================== @@ -507,7 +507,7 @@ So for these we should call `rewriteArgs`. rewriteOpApp :: InferStgExpr -> RM TgStgExpr rewriteOpApp (StgOpApp op args res_ty) = case op of op@(StgPrimOp primOp) - | primOp == SeqOp || primOp == DataToTagOp + | primOp == DataToTagOp -- see Note [Rewriting primop arguments] -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty _ -> pure $! StgOpApp op args res_ty ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -68,11 +68,6 @@ cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args --- seq# a s ==> a --- See Note [seq# magic] in GHC.Core.Opt.ConstantFold -cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = - cgIdApp a [] - -- dataToTagLarge# :: a_levpoly -> Int# -- See Note [DataToTag overview] in GHC.Tc.Instance.Class -- TODO: There are some more optimization ideas for this code path @@ -553,27 +548,6 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: - - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e - -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') --} - -cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts - = -- Note [Handle seq#] - -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold - -- Use the same return convention as vanilla 'a'. - cgCase (StgApp a []) bndr alt_type alts - cgCase scrut bndr alt_type alts = -- the general case do { platform <- getPlatform ===================================== compiler/GHC/StgToCmm/Prim.hs ===================================== @@ -1637,7 +1637,6 @@ emitPrimOp cfg primop = CompactAdd -> alwaysExternal CompactAddWithSharing -> alwaysExternal CompactSize -> alwaysExternal - SeqOp -> alwaysExternal GetSparkOp -> alwaysExternal NumSparks -> alwaysExternal DataToTagOp -> alwaysExternal ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -962,7 +962,6 @@ genPrim prof bound ty op = case op of ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a - SeqOp -> \[_r] [e] -> pure $ PRPrimCall $ returnS (app "h$e" [e]) NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ ------------------------------ Tag to enum stuff -------------------------------- ===================================== compiler/GHC/StgToJS/Utils.hs ===================================== @@ -60,7 +60,7 @@ import GHC.Stg.Syntax import GHC.Tc.Utils.TcType import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -423,8 +423,6 @@ isInlineExpr v = \case -> (emptyUniqSet, True) StgOpApp (StgFCallOp f _) _ _ -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) StgOpApp (StgPrimOp op) _ _ -> (emptyUniqSet, primOpIsReallyInline op) StgOpApp (StgPrimCallOp _c) _ _ ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -31,6 +31,7 @@ module GHC.Types.Id.Make ( realWorldPrimId, voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + seqHashId, seqHashIdName, seqHashIdKey, coercionTokenId, coerceId, proxyHashId, nospecId, nospecIdName, @@ -172,7 +173,14 @@ wiredInIds ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] +magicIds + = [ lazyId + , oneShotId + , noinlineId + , noinlineConstraintId + , nospecId + , seqHashId + ] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1845,10 +1853,11 @@ leftSectionName = mkWiredInIdName gHC_PRIM (fsLit "leftSection") leftSecti rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, nospecIdName :: Name +lazyIdName, oneShotName, nospecIdName, seqHashIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId +seqHashIdName = mkWiredInIdName gHC_MAGIC (fsLit "seq#") seqHashIdKey seqHashId ------------------------------------------------ proxyHashId :: Id @@ -1963,6 +1972,23 @@ oneShotId = pcRepPolyId oneShotName ty concs info concs = mkRepPolyIdConcreteTyVars [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)] +------------------------------------------------ +seqHashId :: Id +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +seqHashId = pcMiscPrelId seqHashIdName ty info + where + info = noCafIdInfo `setArityInfo` 2 + `setDmdSigInfo` dmd_sig + -- forall a b. a -> State# b -> (# State# b, a #) + ty = mkSpecForAllTys [alphaTyVar,deltaTyVar] + $ mkVisFunTyMany alphaTy + $ mkVisFunTyMany state_ty + $ mkTupleTy Unboxed [state_ty, alphaTy] + state_ty = mkStatePrimTy deltaTy + dmd_sig = mkClosedDmdSig [C_01 :* topSubDmd, topDmd] topDiv + -- Why is the demand on the first arg lazy? See Note [seq# magic], (SEQ2) + -- NB: topSubDmd because we don't know how its value is used + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/src/GHC/Exts.hs ===================================== @@ -105,7 +105,7 @@ module GHC.Exts currentCallStack, -- * Ids with special behaviour - inline, noinline, lazy, oneShot, considerAccessible, + inline, noinline, lazy, oneShot, considerAccessible, seq#, -- * SpecConstr annotations SpecConstrAnnotation(..), SPEC (..), ===================================== libraries/ghc-prim/GHC/Magic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,7 +26,7 @@ -- ----------------------------------------------------------------------------- -module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, DataToTag(..) ) where +module GHC.Magic ( inline, noinline, lazy, oneShot, runRW#, seq#, DataToTag(..) ) where -------------------------------------------------- -- See Note [magicIds] in GHC.Types.Id.Make @@ -119,6 +121,14 @@ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). {-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep runRW# m = m realWorld# +-- | The primitive used to implement 'GHC.IO.evaluate', but is subject to +-- breaking changes. For example, this magic Id used to live in "GHC.Prim". +-- Prefer to use 'GHC.IO.evaluate' whenever possible! +seq# :: forall a s. a -> State# s -> (# State# s, a #) +-- See Note [seq# magic] in GHC.Core.Opt.ConstantFold +{-# NOINLINE seq# #-} -- seq# is inlined manually in CorePrep +seq# !a s = (# s, a #) + -- | @'dataToTag#'@ evaluates its argument and returns the index -- (starting at zero) of the constructor used to produce that -- argument. Any algebraic data type with all of its constructors ===================================== testsuite/tests/core-to-stg/T24124.hs ===================================== @@ -0,0 +1,36 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Debug.Trace +import GHC.IO +import GHC.ST + +data StrictPair a b = !a :*: !b + +strictFun :: Int -> Int +{-# OPAQUE strictFun #-} +strictFun x = x*x*x + +opaqueId :: a -> a +{-# OPAQUE opaqueId #-} +{-# RULES + "opaqueId/noinline" opaqueId = noinline +#-} +-- work around noinline's special desugaring +opaqueId v = v + +evaluateST :: a -> ST s a +-- hide the fact that we are actually in IO because !11515 +-- causes seq# to look like it can throw precise exceptions +evaluateST x = ST (\s -> seq# x s) + +fun :: Int -> Int -> ST s Int +{-# OPAQUE fun #-} +fun = lazy $ \ !x y -> do + -- This should evaluate x before y. + _ <- evaluateST $ opaqueId (x :*: x) + _ <- evaluateST y + evaluateST $! strictFun x + +main :: IO () +main = () <$ stToIO (fun (trace "x eval'd" 12) (trace "y eval'd" 13)) ===================================== testsuite/tests/core-to-stg/T24124.stderr ===================================== @@ -0,0 +1,2 @@ +x eval'd +y eval'd ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -4,3 +4,4 @@ test('T19700', normal, compile, ['-O']) test('T23270', [grep_errmsg(r'patError')], compile, ['-O0 -dsuppress-uniques -ddump-prep']) test('T23914', normal, compile, ['-O']) test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) +test('T24124', normal, compile_and_run, ['-O']) ===================================== testsuite/tests/simplStg/should_compile/T15226b.stderr ===================================== @@ -17,23 +17,21 @@ T15226b.testFun1 -> b -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, T15226b.StrictPair a b #) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [x y void] - case seq# [x GHC.Prim.void#] of ds1 { - Solo# ipv1 [Occ=Once1] -> - let { - sat [Occ=Once1] :: T15226b.StrictPair a b - [LclId] = - {ipv1, y} \u [] - case y of conrep { - __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep]; - }; - } in seq# [sat GHC.Prim.void#]; + case x of sat { + __DEFAULT -> + case y of conrep { + __DEFAULT -> + case T15226b.MkStrictPair [sat conrep] of sat { + __DEFAULT -> Solo# [sat]; + }; + }; }; T15226b.testFun :: forall a b. a -> b -> GHC.Types.IO (T15226b.StrictPair a b) -[GblId, Arity=3, Str=, Unf=OtherCon []] = +[GblId, Arity=3, Str=, Unf=OtherCon []] = {} \r [eta eta void] T15226b.testFun1 eta eta GHC.Prim.void#; T15226b.MkStrictPair [InlPrag=CONLIKE] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e128b9a575f16f085a0de9d5d594b5d4c5af8c44 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e128b9a575f16f085a0de9d5d594b5d4c5af8c44 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 Dec 18 09:26:30 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 04:26:30 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 3 commits: ghcup-metadata: Use dynamically linked alpine bindists Message-ID: <65801046de50f_e7a73659323fc331970@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 123b0cf7 by Matthew Pickering at 2023-12-18T14:56:22+05:30 ghcup-metadata: Use dynamically linked alpine bindists In theory these will work much better on alpine to allow people to build statically linked applications there. We don't need to distribute a statically linked application ourselves in order to allow that. Fixes #23602 (cherry picked from commit e524fa7f67259a093aeb21aada139137626c581c) - - - - - de70b89d by Rodrigo Mesquita at 2023-12-18T14:56:22+05:30 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. (cherry picked from commit e98051a5e7251390799f9fdead988c61d72e82e3) - - - - - f6ff2c25 by Zubin Duggal at 2023-12-18T14:56:22+05:30 Prepare release 9.6.4 - - - - - 7 changed files: - .gitlab-ci.yml - .gitlab/gen_ci.hs - configure.ac - distrib/configure.ac.in - + docs/users_guide/9.6.4-notes.rst - docs/users_guide/release-notes.rst - + m4/fp_ld_no_warn_duplicate_libraries.m4 Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1018,7 +1018,7 @@ ghcup-metadata-nightly: artifacts: false - job: nightly-x86_64-windows-validate artifacts: false - - job: nightly-x86_64-linux-alpine3_12-int_native-validate+fully_static + - job: nightly-x86_64-linux-alpine3_12-validate artifacts: false - job: nightly-x86_64-linux-deb9-validate artifacts: false ===================================== .gitlab/gen_ci.hs ===================================== @@ -955,7 +955,7 @@ platform_mapping :: Map String (JobGroup BindistInfo) platform_mapping = Map.map go $ Map.fromListWith combine [ (uncurry mkPlatform (jobPlatform (jobInfo $ v j)), j) | j <- filter hasReleaseBuild job_groups ] where - whitelist = [ "x86_64-linux-alpine3_12-int_native-validate+fully_static" + whitelist = [ "x86_64-linux-alpine3_12-validate" , "x86_64-linux-deb10-validate" , "x86_64-linux-deb11-validate" , "x86_64-linux-fedora33-release" ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the @@ -655,11 +655,17 @@ FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAG FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) # Stage 3 won't be supported by cross-compilation +#-no_fixup_chains FP_LD_NO_FIXUP_CHAINS([target], [LDFLAGS]) FP_LD_NO_FIXUP_CHAINS([build], [CONF_GCC_LINKER_OPTS_STAGE0]) FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE1]) FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE2]) +#-no_warn_duplicate_libraries +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([build], [CONF_GCC_LINKER_OPTS_STAGE0]) +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE1]) +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE2]) + GHC_LLVM_TARGET_SET_VAR # we intend to pass trough --targets to llvm as is. LLVMTarget_CPP=` echo "$LlvmTarget"` ===================================== distrib/configure.ac.in ===================================== @@ -173,11 +173,17 @@ FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE1],[CONF_GCC_LINKER_OPTS_STAG # Stage 3 won't be supported by cross-compilation FPTOOLS_SET_C_LD_FLAGS([target],[CONF_CC_OPTS_STAGE2],[CONF_GCC_LINKER_OPTS_STAGE2],[CONF_LD_LINKER_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) +#-no_fixup_chains FP_LD_NO_FIXUP_CHAINS([target], [LDFLAGS]) FP_LD_NO_FIXUP_CHAINS([build], [CONF_GCC_LINKER_OPTS_STAGE0]) FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE1]) FP_LD_NO_FIXUP_CHAINS([target], [CONF_GCC_LINKER_OPTS_STAGE2]) +#-no_warn_duplicate_libraries +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([build], [CONF_GCC_LINKER_OPTS_STAGE0]) +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE1]) +FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE2]) + AC_SUBST(CONF_CC_OPTS_STAGE0) AC_SUBST(CONF_CC_OPTS_STAGE1) AC_SUBST(CONF_CC_OPTS_STAGE2) ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -0,0 +1,123 @@ +.. _release-9-6-4: + +Version 9.6.4 +============== + +The significant changes to the various parts of the compiler are listed below. +See the `migration guide +`_ on the GHC Wiki +for specific guidance on migrating programs to this release. + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM +11, 12, 13, 14 or 15. + +Significant Changes +~~~~~~~~~~~~~~~~~~~~ + +Issues fixed in this release include: + +Compiler +-------- + +- Fix a code generator bug on AArch64 platforms resulting in invalid conditional + jumps (:ghc-ticket:`23746`). +- Fix a simplifier bug that may cause segfaults and core lint failures due to + incorrect handling of join points (:ghc-ticket:`23952`). +- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`). +- Fix a bug where we could silently truncate 64 bit values to 32 bit on + 32 bit architectures. +- Fix a GHCi bug where a failure in the ``:add`` command would cause the + process to exit (:ghc-ticket:`24115`). +- Fix a bug causing suboptimal error messages for certain invalid cyclic + module graphs with hs-boot files (:ghc-ticket:`24196`). +- Fix a bug causing compiler panics with certain package databases involving + unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`, + :ghc-ticket:`11050`). +- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`, + :ghc-ticket:`24118`). +- Fix a bug leading to some template haskell splices failing on being reloaded + into GHCi due to not clearing the interactive context properly + (:ghc-ticket:`23405`). +- Fix a type checker crash on certain programs involving implicitly scoped type + 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`). + +Runtime system +-------------- + +- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`). +- Ensure the ``listAllBlocks`` function takes the non-moving heap into account + (:ghc-ticket:`22627`). +- Ensure the non-moving GC is not running when pausing +- Fix some non-moving loops and bugs on Windows and LLP64 platforms + (:ghc-ticket:`23003`, :ghc-ticket:`24042`). +- Fix a bug where certain programs could have incorrect async exception masking + (:ghc-ticket:`23513`). +- Ensure we respect maximum event length and don't overflow into program + memory (:ghc-ticket:`24197`). + +Build system and packaging +-------------------------- + +- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`, + :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`). + +Core libraries +-------------- + +- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in + out of bounds access (:ghc-ticket:`24066`). +- Bump ``base`` to 4.18.2.0 +- base: Update to Unicode 15.1.0 +- Bump ``filepath`` to 1.4.200.1 +- Bump ``unix`` to 2.8.4.0 +- Bump ``haddock`` to 2.29.2 + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + ===================================== docs/users_guide/release-notes.rst ===================================== @@ -7,3 +7,4 @@ Release notes 9.6.1-notes 9.6.2-notes 9.6.3-notes + 9.6.4-notes ===================================== m4/fp_ld_no_warn_duplicate_libraries.m4 ===================================== @@ -0,0 +1,29 @@ +# FP_LD_NO_WARN_DUPLICATE_LIBRARIES +# --------------------------------- +# 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. +# +# $1 = the platform +# $2 = the name of the linker flags variable when linking with $CC +AC_DEFUN([FP_LD_NO_WARN_DUPLICATE_LIBRARIES], [ + case $$1 in + *-darwin) + AC_MSG_CHECKING([whether the linker requires -no_warn_duplicate_libraries]) + echo 'int main(void) {return 0;}' > conftest.c + if $CC -o conftest -Wl,-no_warn_duplicate_libraries conftest.c > /dev/null 2>&1 + then + $2="$$2 -Wl,-no_warn_duplicate_libraries" + AC_MSG_RESULT([yes]) + else + AC_MSG_RESULT([no]) + fi + rm -f conftest.c conftest.o conftest + ;; + + esac +]) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/87c9851436246ac862ae1107232da0f28182c65f...f6ff2c25369402c44095572a020d6f924c5a8a3a -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/87c9851436246ac862ae1107232da0f28182c65f...f6ff2c25369402c44095572a020d6f924c5a8a3a 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 Dec 18 09:39:59 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 04:39:59 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] wip Message-ID: <6580136f7cca8_e7a736600c10033244d@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 5935dc60 by Zubin Duggal at 2023-12-18T15:09:51+05:30 wip - - - - - 1 changed file: - .gitlab/ci.sh Changes: ===================================== .gitlab/ci.sh ===================================== @@ -616,7 +616,7 @@ function test_hadrian() { # hello.wasm depending on the backend. For the time being let's # just move it to hello before proceeding to running it. mv hello.wasm hello || true - ${CROSS_EMULATOR:-} ./hello > actual + run ${CROSS_EMULATOR:-} ./hello > actual run diff expected actual elif [[ -n "${REINSTALL_GHC:-}" ]]; then run_hadrian \ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5935dc60b3f74553819eb16e478fb980ca058caf -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5935dc60b3f74553819eb16e478fb980ca058caf 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 Dec 18 09:56:08 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 04:56:08 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] wip Message-ID: <658017389881a_e7a736679ee6833445a@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: cff8f688 by Zubin Duggal at 2023-12-18T15:25:57+05:30 wip - - - - - 1 changed file: - .gitlab/ci.sh Changes: ===================================== .gitlab/ci.sh ===================================== @@ -616,6 +616,7 @@ function test_hadrian() { # hello.wasm depending on the backend. For the time being let's # just move it to hello before proceeding to running it. mv hello.wasm hello || true + mv hello.jsexe hello || true run ${CROSS_EMULATOR:-} ./hello > actual run diff expected actual elif [[ -n "${REINSTALL_GHC:-}" ]]; then View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cff8f6883eea1dc9dabf987224611f98ac4f35d1 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cff8f6883eea1dc9dabf987224611f98ac4f35d1 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 Dec 18 10:10:39 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 18 Dec 2023 05:10:39 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Late plugins Message-ID: <65801a9f6e5a5_e7a7366eaed8434252a@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - a3b40b75 by ur4t at 2023-12-18T05:10:14-05:00 GHCi: fix improper location of ghci_history file Fixes #24266 - - - - - 10 changed files: - compiler/GHC/Core/LateCC.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Plugins.hs - docs/users_guide/9.10.1-notes.rst - docs/users_guide/extending_ghc.rst - ghc/GHCi/UI.hs - testsuite/tests/plugins/Makefile - testsuite/tests/plugins/all.T - + testsuite/tests/plugins/late-plugin/LatePlugin.hs - + testsuite/tests/plugins/test-late-plugin.hs Changes: ===================================== compiler/GHC/Core/LateCC.hs ===================================== @@ -71,34 +71,32 @@ addLateCostCentresMG guts = do let env :: Env env = Env { thisModule = mg_module guts - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = False -- See Note [Collecting late cost centres] } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) + let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts)) } return guts' -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) +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) -> a `seqList` (b `seq` ())) $ do + (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do let env = Env { thisModule = mod - , ccState = newCostCentreState , countEntries = gopt Opt_ProfCountEntries dflags , collectCCs = True -- See Note [Collecting late cost centres] } - (binds', ccs) = addLateCostCentres env binds + (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) + return (binds', ccs, cc_state) -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) +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) + in (binds', lcs_ccs state, lcs_state state) doBind :: Env -> CoreBind -> M CoreBind @@ -161,7 +159,6 @@ addCC !env cc = do data Env = Env { thisModule :: !Module , countEntries:: !Bool - , ccState :: !CostCentreState , collectCCs :: !Bool } ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -297,6 +297,7 @@ 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) {- ********************************************************************** @@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- -- Insert late cost centres 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) <- + (late_cc_binds, late_local_ccs, cc_state) <- if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + 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) + return (core_binds, local_ccs, newCostCentreState) + + ------------------- + -- Run late plugins + -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info, + cg_spt_entries = spt_entries, + cg_binds = late_binds, + cg_ccs = late_local_ccs' + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = late_local_ccs + } + , cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes @@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do (hsc_logger hsc_env) cp_cfg (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + this_mod location late_binds data_tycons ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1845,7 +1876,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/Plugins.hs ===================================== @@ -58,6 +58,10 @@ module GHC.Driver.Plugins ( -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ data Plugin = Plugin { -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +294,7 @@ defaultPlugin = Plugin { , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return ===================================== docs/users_guide/9.10.1-notes.rst ===================================== @@ -126,6 +126,9 @@ Compiler - The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`, as ``forall`` is no longer parsed as an identifier. +- 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`. + GHCi ~~~~ ===================================== docs/users_guide/extending_ghc.rst ===================================== @@ -510,6 +510,58 @@ in a module it compiles: return bndr printBind _ bndr = return bndr +.. _late-plugins: + +Late Plugins +^^^^^^^^^^^^ + +If the ``CoreProgram`` of a module is modified in a normal core plugin, the +modified bindings can end up in unfoldings the interface file for the module. +This may be undesireable, as the plugin could make changes which affect inlining +or optimization. + +Late plugins can be used to avoid introducing such changes into the interface +file. Late plugins are a bit different from typical core plugins: + +1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed + the ``HscEnv`` and they run in ``IO``. +2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted + form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in + the ``CgGuts`` given to a late plugin will already be fully optimized. +3. They must maintain a ``CostCentreState`` and track any cost centres they + introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is + because the automatic collection of cost centres happens before the late + plugin stage. If a late plugin does not introduce any cost centres, it may + simply return the given cost centre state. + +Here is a very simply example of a late plugin that changes the value of a +binding in a module. If it finds a non-recursive top-level binding named +``testBinding`` with type ``Int``, it will change its value to the ``Int`` +expression ``111111``. + +:: + + plugin :: Plugin + plugin = defaultPlugin { latePlugin = lateP } + + lateP :: LatePlugin + lateP _ _ (cg_guts, cc_state) = do + binds' <- editCoreBinding (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + + editCoreBinding :: CoreProgram -> IO CoreProgram + editCoreBinding pgm = pure . go + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr 111111) : bs + go (b:bs) = b : go bs + go [] = [] + +Since this is a late plugin, the changed binding value will not end up in the +interface file. + .. _getting-annotations: Using Annotations ===================================== ghc/GHCi/UI.hs ===================================== @@ -639,30 +639,27 @@ ghciLogAction lastErrLocations old_log_action _ -> return () _ -> return () --- | Takes a file name and prefixes it with the appropriate --- GHC appdir. --- Uses ~/.ghc (getAppUserDataDirectory) if it exists --- If it doesn't, then it uses $XDG_DATA_HOME/ghc --- Earlier we always used to use ~/.ghc, but we want --- to gradually move to $XDG_DATA_HOME to respect the XDG specification --- --- As a migration strategy, we will only create new directories in --- the appropriate XDG location. However, we will use the old directory --- if it already exists. -getAppDataFile :: FilePath -> IO (Maybe FilePath) -getAppDataFile file = do - let new_path = tryIO (getXdgDirectory XdgConfig "ghc") >>= \case - Left _ -> pure Nothing - Right dir -> flip catchIO (const $ return Nothing) $ do - createDirectoryIfMissing False dir - pure $ Just $ dir file - - e_old_path <- tryIO (getAppUserDataDirectory "ghc") - case e_old_path of - Right old_path -> doesDirectoryExist old_path >>= \case - True -> pure $ Just $ old_path file - False -> new_path - Left _ -> new_path +-- | Takes a file name and prefixes it with the appropriate GHC appdir. +-- ~/.ghc (getAppUserDataDirectory) is used if it exists, or XDG directories +-- are used to respect the XDG specification. +-- As a migration strategy, currently we will only create new directories in +-- the appropriate XDG location. +getAppDataFile :: XdgDirectory -> FilePath -> IO (Maybe FilePath) +getAppDataFile xdgDir file = do + xdgAppDir <- + tryIO (getXdgDirectory xdgDir "ghc") >>= \case + Left _ -> pure Nothing + Right dir -> flip catchIO (const $ pure Nothing) $ do + createDirectoryIfMissing False dir + pure $ Just dir + appDir <- + tryIO (getAppUserDataDirectory "ghc") >>= \case + Right dir -> + doesDirectoryExist dir >>= \case + True -> pure $ Just dir + False -> pure xdgAppDir + Left _ -> pure xdgAppDir + pure $ appDir >>= \dir -> Just $ dir file runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do @@ -670,13 +667,12 @@ runGHCi paths maybe_exprs = do let ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags - app_user_dir = liftIO $ getAppDataFile "ghci.conf" + appDataCfg = liftIO $ getAppDataFile XdgConfig "ghci.conf" - home_dir = do - either_dir <- liftIO $ tryIO (getEnv "HOME") - case either_dir of - Right home -> return (Just (home ".ghci")) - _ -> return Nothing + homeCfg = do + liftIO $ tryIO (getEnv "HOME") >>= \case + Right home -> pure $ Just $ home ".ghci" + _ -> pure Nothing canonicalizePath' :: FilePath -> IO (Maybe FilePath) canonicalizePath' fp = liftM Just (canonicalizePath fp) @@ -710,7 +706,7 @@ runGHCi paths maybe_exprs = do then pure [] else do userCfgs <- do - paths <- catMaybes <$> sequence [ app_user_dir, home_dir ] + paths <- catMaybes <$> sequence [ appDataCfg, homeCfg ] checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths @@ -797,12 +793,12 @@ runGHCiInput f = do dflags <- getDynFlags let ghciHistory = gopt Opt_GhciHistory dflags let localGhciHistory = gopt Opt_LocalGhciHistory dflags - currentDirectory <- liftIO $ getCurrentDirectory + currentDirectory <- liftIO getCurrentDirectory histFile <- case (ghciHistory, localGhciHistory) of - (True, True) -> return (Just (currentDirectory ".ghci_history")) - (True, _) -> liftIO $ getAppDataFile "ghci_history" - _ -> return Nothing + (True, True) -> pure $ Just $ currentDirectory ".ghci_history" + (True, _) -> liftIO $ getAppDataFile XdgData "ghci_history" + _ -> pure Nothing runInputT (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -224,3 +224,13 @@ plugins-external: cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin) "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs ./plugins-external + +# Runs a plugin that is both a core plugin and a late plugin, then makes sure +# only the changes from the core plugin end up in the interface files. +test-late-plugin: + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs + SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \ + ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \ + ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \ + echo "$$ContainsLateBinding" ; \ + [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ] ===================================== testsuite/tests/plugins/all.T ===================================== @@ -358,3 +358,8 @@ test('test-log-hooks-plugin', pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')], compile_fail, ['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags]) + +test('test-late-plugin', + [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout], + makefile_test, + []) ===================================== testsuite/tests/plugins/late-plugin/LatePlugin.hs ===================================== @@ -0,0 +1,50 @@ +module LatePlugin where + +import Data.Bool +import GHC.Core +import GHC.Core.TyCo.Compare +import GHC.Driver.Monad +import GHC.Plugins +import GHC.Types.Avail +import GHC.Types.Var +import GHC.Types.Id +import System.IO + +-- | Both a core plugin and a late plugin. The Core plugin edits the binding in +-- the test file (testBinding) to be the integer "111111". The late plugin then +-- edits the binding to be the integer "222222". Then we make sure the "222222" +-- did not make it in the interface file and the "111111" did. +plugin :: Plugin +plugin = + defaultPlugin + { installCoreToDos = earlyP + , latePlugin = lateP + } + +earlyP :: CorePlugin +earlyP _ todos = do + return + . (: todos) + $ CoreDoPluginPass "earlyP" + $ \mgs -> liftIO $ do + binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs) + return mgs { mg_binds = binds' } + +lateP :: LatePlugin +lateP _ opts (cg_guts, cc_state) = do + binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts) + return (cg_guts { cg_binds = binds' }, cc_state) + +editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram +editCoreBinding early modName pgm = do + putStrLn $ + bool "late " "early " early ++ "plugin running on module " ++ + moduleNameString modName + pure $ go pgm + where + go :: [CoreBind] -> [CoreBind] + go (b@(NonRec v e) : bs) + | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy = + NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs + go (b:bs) = b : go bs + go [] = [] ===================================== testsuite/tests/plugins/test-late-plugin.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fplugin=LatePlugin #-} + +module TestLatePlugin (testBinding) where + +import GHC.Exts + +-- This file is edited by a core plugin at the beginning of the core pipeline so +-- that the value of testBinding becomes 111111. Then, a late plugin edits the +-- binding to set testBinding to 222222. The test then checks that the early +-- binding value is what makes it into the interface file, just to be sure that +-- changes from late plugins do not end up in interface files. + +testBinding :: Int +testBinding = -1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88346e1951317ac6f712ea7bb50424e835c52195...a3b40b75a2b6bb57cec10b0cf931a896079f17fb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88346e1951317ac6f712ea7bb50424e835c52195...a3b40b75a2b6bb57cec10b0cf931a896079f17fb 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 Dec 18 12:43:15 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 07:43:15 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] darwin: Fix single_module is obsolete warning Message-ID: <65803e6387468_e7a736a9694d836792b@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 862a2250 by Rodrigo Mesquita at 2023-12-18T18:13:04+05:30 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 (cherry picked from commit e6c803f702e8b09dfd0073b973b8afcd7071db50) - - - - - 10 changed files: - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - configure.ac - distrib/configure.ac.in - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Rules/Generate.hs - + m4/fp_prog_ld_single_module.m4 Changes: ===================================== compiler/GHC/Linker/Dynamic.hs ===================================== @@ -11,6 +11,7 @@ where import GHC.Prelude import GHC.Platform import GHC.Platform.Ways +import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -150,6 +151,9 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages -- dynamic binding nonsense when referring to symbols from -- within the library. The NCG assumes that this option is -- specified (on i386, at least). + -- In XCode 15, -single_module is the default and passing the + -- flag is now obsolete and raises a warning (#24168). We encode + -- this information into the toolchain field ...SupportsSingleModule. -- -install_name -- Mac OS/X stores the path where a dynamic library is (to -- be) installed in the library itself. It's called the @@ -175,8 +179,11 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages ] ++ map Option o_files ++ [ Option "-undefined", - Option "dynamic_lookup", - Option "-single_module" ] + Option "dynamic_lookup" + ] + ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags) + then [ Option "-single_module" ] + else [ ]) ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] then [ ] else [ Option "-Wl,-read_only_relocs,suppress" ]) ===================================== compiler/GHC/Settings.hs ===================================== @@ -87,6 +87,7 @@ data Settings = Settings data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsFilelist :: Bool + , toolSettings_ldSupportsSingleModule :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -95,6 +95,7 @@ initSettings top_dir = do cxx_args = words cxx_args_str ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldSupportsSingleModule <- getBooleanSetting "ld supports single module" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" arSupportsDashL <- getBooleanSetting "ar supports -L" @@ -163,6 +164,7 @@ initSettings top_dir = do , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW ===================================== configure.ac ===================================== @@ -502,6 +502,7 @@ FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND FP_PROG_LD_FILELIST +FP_PROG_LD_SINGLE_MODULE dnl ** Which nm to use? dnl -------------------------------------------------------------- ===================================== distrib/configure.ac.in ===================================== @@ -134,6 +134,7 @@ FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND FP_PROG_LD_FILELIST +FP_PROG_LD_SINGLE_MODULE dnl ** which strip to use? dnl -------------------------------------------------------------- ===================================== hadrian/bindist/Makefile ===================================== @@ -92,6 +92,7 @@ lib/settings : config.mk @echo ',("ld flags", "$(SettingsLdFlags)")' >> $@ @echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@ @echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@ + @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@ @echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@ @echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@ @echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -240,6 +240,7 @@ LdHasBuildId = @LdHasBuildId@ LdHasFilelist = @LdHasFilelist@ LdIsGNULd = @LdIsGNULd@ LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ +LdHasSingleModule = @LdHasSingleModule@ ArArgs = @ArArgs@ ArSupportsAtFile = @ArSupportsAtFile@ ArSupportsDashL = @ArSupportsDashL@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -141,6 +141,7 @@ gcc-extra-via-c-opts = @GccExtraViaCOpts@ ld-has-no-compact-unwind = @LdHasNoCompactUnwind@ ld-has-filelist = @LdHasFilelist@ ld-is-gnu-ld = @LdIsGNULd@ +ld-supports-single-module = @LdHasSingleModule@ ar-args = @ArArgs@ settings-c-compiler-command = @SettingsCCompilerCommand@ ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -430,6 +430,7 @@ generateSettings = do , ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind") , ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist") , ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld") + , ("ld supports single module", expr $ lookupSystemConfig "ld-supports-single-module") , ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand) , ("Merge objects flags", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsFlags) , ("ar command", expr $ settingsFileSetting SettingsFileSetting_ArCommand) ===================================== m4/fp_prog_ld_single_module.m4 ===================================== @@ -0,0 +1,30 @@ +# FP_PROG_LD_SINGLE_MODULE +# ---------------------------- +# Sets the output variable LdHasSingleModule to YES if the darwin ld supports +# -single_module, or NO otherwise. +# +# In XCode 15, -single_module is a default and passing it as a flag raises a +# warning. +AC_DEFUN([FP_PROG_LD_SINGLE_MODULE], +[ +AC_CACHE_CHECK([whether ld supports -single_module], [fp_cv_ld_single_module], +[ +case $target in + *-darwin) + echo 'int foo(int x) { return x*x; }' > conftest.c + echo 'extern int foo(int); int main() { return foo(5); }' > conftestmain.c + "$CC" -c -o conftestmain.o conftestmain.c + "$CC" -shared -o conftest.dylib conftest.c + if "$CC" -Wl,-single_module -o conftest conftestmain.o conftest.dylib 2>&1 | grep obsolete > /dev/null; then + fp_cv_ld_single_module=no + else + fp_cv_ld_single_module=yes + fi + rm -rf conftest* ;; + *) + fp_cv_ld_single_module=no ;; +esac +]) +FP_CAPITALIZE_YES_NO(["$fp_cv_ld_single_module"], [LdHasSingleModule]) +AC_SUBST([LdHasSingleModule]) +])# FP_PROG_LD_SINGLE_MODULE View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/862a225013247e09621164bcead3befcadb6ba17 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/862a225013247e09621164bcead3befcadb6ba17 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 Dec 18 13:27:07 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 18 Dec 2023 08:27:07 -0500 Subject: [Git][ghc/ghc][wip/expand-do] remove isGoodCoverateExpr. it is not needed Message-ID: <658048abcd205_e7a736b861f80375941@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 47cb6dc5 by Apoorv Ingle at 2023-12-18T07:26:49-06:00 remove isGoodCoverateExpr. it is not needed - - - - - 1 changed file: - compiler/GHC/HsToCore/Ticks.hs Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -375,7 +375,7 @@ addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage | isGoodCoverageExpr e0 -> tick_it + TickForCoverage -> tick_it TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where @@ -393,7 +393,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 +409,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,30 +440,12 @@ 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 +isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt stmt) _)) + | LastStmt{} <- unLoc stmt = True | otherwise - = isCallSite e -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 - +isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True @@ -479,12 +460,12 @@ 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 - (allocTickBox (ExpBox oneOfMany) False False (locA pos) - $ addTickHsExpr e0) - (addTickLHsExpr e) - else (addTickLHsExprNever e) + = if isExpansion + then addTickLHsExprNever e + else ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False (locA pos) + $ addTickHsExpr e0) + (addTickLHsExpr e) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0) @@ -650,7 +631,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 }) = View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47cb6dc58d3875e40ef995f88dddaa1e792a1536 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/47cb6dc58d3875e40ef995f88dddaa1e792a1536 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 Dec 18 14:16:15 2023 From: gitlab at gitlab.haskell.org (Matthew Craven (@clyring)) Date: Mon, 18 Dec 2023 09:16:15 -0500 Subject: [Git][ghc/ghc][wip/T24264] StgToCmm: Detect some no-op case-continuations Message-ID: <6580542fcba28_e7a736d09ec243858d2@gitlab.mail> Matthew Craven pushed to branch wip/T24264 at Glasgow Haskell Compiler / GHC Commits: 6ebfa5f2 by Matthew Craven at 2023-12-18T09:15:35-05:00 StgToCmm: Detect some no-op case-continuations ...and generate no code for them. Fixes #24264. - - - - - 6 changed files: - compiler/GHC/StgToCmm/Expr.hs - + 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 Changes: ===================================== 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 ===================================== testsuite/tests/codeGen/should_compile/T24264.hs ===================================== @@ -0,0 +1,18 @@ +module T24264 where + +fun :: a -> IO a +{-# OPAQUE fun #-} +fun x = do + pure () + pure $! x + -- This should not push a continuation to the stack before entering 'x' + +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,70 @@ + +==================== Output Cmm ==================== +[T24264.fun_entry() { // [R2] + { info_tbls: [(cKd, + label: T24264.fun_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cKd: // global + // slowCall + R1 = R2; // CmmAssign + call stg_ap_0_fast(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }, + section ""data" . T24264.fun_closure" { + T24264.fun_closure: + const T24264.fun_info; + }] + + + +==================== Output Cmm ==================== +[T24264.funPair_entry() { // [R2] + { info_tbls: [(cKn, + label: block_cKn_info + rep: StackRep [] + srt: Nothing), + (cKq, + label: T24264.funPair_info + rep: HeapRep static { Fun {arity: 2 fun_type: ArgSpec 5} } + srt: Nothing)] + stack_info: arg_space: 8 + } + {offset + cKq: // global + if ((Sp + -8) < SpLim) (likely: False) goto cKr; else goto cKs; // CmmCondBranch + cKr: // global + R1 = T24264.funPair_closure; // CmmAssign + call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall + cKs: // global + // slowCall + I64[Sp - 8] = cKn; // CmmStore + R1 = R2; // CmmAssign + Sp = Sp - 8; // CmmAssign + call stg_ap_0_fast(R1) returns to cKn, args: 8, res: 8, upd: 8; // CmmCall + cKn: // global + // slow_call for _sK3::P64 with pat stg_ap_0 + Hp = Hp + 24; // CmmAssign + if (Hp > HpLim) (likely: False) goto cKv; else goto cKu; // CmmCondBranch + cKv: // global + HpAlloc = 24; // CmmAssign + call stg_gc_unpt_r1(R1) returns to cKn, args: 8, res: 8, upd: 8; // CmmCall + cKu: // global + // allocHeapClosure + I64[Hp - 16] = (,)_con_info; // CmmStore + P64[Hp - 8] = R1; // CmmStore + P64[Hp] = R1; // CmmStore + R1 = Hp - 15; // CmmAssign + Sp = Sp + 8; // CmmAssign + call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall + } + }, + section ""data" . T24264.funPair_closure" { + T24264.funPair_closure: + const T24264.funPair_info; + }] + + ===================================== 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', grep_errmsg(r'(.*\().*(\) returns to)', [1,2]), + compile, ['-O -ddump-cmm -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, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ebfa5f2d03c680e54e34b3d5df42b371b433e01 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ebfa5f2d03c680e54e34b3d5df42b371b433e01 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 Dec 18 15:03:42 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 10:03:42 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 4 commits: darwin: Fix single_module is obsolete warning Message-ID: <65805f4ddba20_e7a736df5252c3995a1@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 273f5a3f by Rodrigo Mesquita at 2023-12-18T20:33:03+05:30 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 (cherry picked from commit e6c803f702e8b09dfd0073b973b8afcd7071db50) - - - - - 000a6a8f by Josh Meredith at 2023-12-18T20:33:03+05:30 JS: fix bounds checking (Issue 23123) * For ByteArray-based bounds-checking, the JavaScript backend must use the `len` field, instead of the inbuild JavaScript `length` field. * Range-based operations must also check both the start and end of the range for bounds * All indicies are valid for ranges of size zero, since they are essentially no-ops * For cases of ByteArray accesses (e.g. read as Int), the end index is (i * sizeof(type) + sizeof(type) - 1), while the previous implementation uses (i + sizeof(type) - 1). In the Int32 example, this is (i * 4 + 3) * IndexByteArrayOp_Word8As* primitives use byte array indicies (unlike the previous point), but now check both start and end indicies * Byte array copies now check if the arrays are the same by identity and then if the ranges overlap. (cherry picked from commit 116d7312ec4c76f75a26bd0ad2b2815710049e0e) - - - - - 689375f4 by Sylvain Henry at 2023-12-18T20:33:03+05:30 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. (cherry picked from commit 2d5c1ddecf195da9a8ee4f7b38fbb79d3b680aeb) - - - - - 3ce937a7 by Zubin Duggal at 2023-12-18T20:33:03+05:30 Prepare release 9.6.4 - - - - - 22 changed files: - compiler/GHC/Linker/Dynamic.hs - compiler/GHC/Settings.hs - compiler/GHC/Settings/IO.hs - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - configure.ac - distrib/configure.ac.in - + docs/users_guide/9.6.4-notes.rst - docs/users_guide/release-notes.rst - hadrian/bindist/Makefile - hadrian/bindist/config.mk.in - hadrian/cfg/system.config.in - hadrian/src/Rules/Generate.hs - libraries/base/jsbits/base.js - + m4/fp_prog_ld_single_module.m4 - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_fail/all.T - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/Linker/Dynamic.hs ===================================== @@ -11,6 +11,7 @@ where import GHC.Prelude import GHC.Platform import GHC.Platform.Ways +import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) import GHC.Driver.Config.Linker import GHC.Driver.Session @@ -150,6 +151,9 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages -- dynamic binding nonsense when referring to symbols from -- within the library. The NCG assumes that this option is -- specified (on i386, at least). + -- In XCode 15, -single_module is the default and passing the + -- flag is now obsolete and raises a warning (#24168). We encode + -- this information into the toolchain field ...SupportsSingleModule. -- -install_name -- Mac OS/X stores the path where a dynamic library is (to -- be) installed in the library itself. It's called the @@ -175,8 +179,11 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages ] ++ map Option o_files ++ [ Option "-undefined", - Option "dynamic_lookup", - Option "-single_module" ] + Option "dynamic_lookup" + ] + ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags) + then [ Option "-single_module" ] + else [ ]) ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] then [ ] else [ Option "-Wl,-read_only_relocs,suppress" ]) ===================================== compiler/GHC/Settings.hs ===================================== @@ -87,6 +87,7 @@ data Settings = Settings data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsFilelist :: Bool + , toolSettings_ldSupportsSingleModule :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool ===================================== compiler/GHC/Settings/IO.hs ===================================== @@ -95,6 +95,7 @@ initSettings top_dir = do cxx_args = words cxx_args_str ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" + ldSupportsSingleModule <- getBooleanSetting "ld supports single module" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" arSupportsDashL <- getBooleanSetting "ar supports -L" @@ -163,6 +164,7 @@ initSettings top_dir = do , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist + , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -137,6 +137,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,214 +526,201 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsChecked bound a (Add i 3) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) - . boundsChecked bound a2 (Add o2 (Sub n 1)) - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -752,107 +738,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -913,17 +850,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1027,184 +964,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsChecked bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsChecked bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsChecked bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1363,6 +1198,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1387,6 +1295,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1402,6 +1322,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1412,6 +1342,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1427,8 +1369,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1440,39 +1382,174 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -boundsChecked False _ _ r = r -boundsChecked True xs i r = - ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound + :: JExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ First array + -> JExpr -- ^ First offset + -> JExpr -- ^ Second array + -> JExpr -- ^ Second offset + -> JExpr -- ^ Range size + -> JStat -- ^ Result + -> JStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. -- So (x|0) * (y|0) can still return values outside of the Int32 range. You have ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the @@ -502,6 +502,7 @@ FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND FP_PROG_LD_FILELIST +FP_PROG_LD_SINGLE_MODULE dnl ** Which nm to use? dnl -------------------------------------------------------------- ===================================== distrib/configure.ac.in ===================================== @@ -134,6 +134,7 @@ FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND FP_PROG_LD_FILELIST +FP_PROG_LD_SINGLE_MODULE dnl ** which strip to use? dnl -------------------------------------------------------------- ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -0,0 +1,123 @@ +.. _release-9-6-4: + +Version 9.6.4 +============== + +The significant changes to the various parts of the compiler are listed below. +See the `migration guide +`_ on the GHC Wiki +for specific guidance on migrating programs to this release. + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM +11, 12, 13, 14 or 15. + +Significant Changes +~~~~~~~~~~~~~~~~~~~~ + +Issues fixed in this release include: + +Compiler +-------- + +- Fix a code generator bug on AArch64 platforms resulting in invalid conditional + jumps (:ghc-ticket:`23746`). +- Fix a simplifier bug that may cause segfaults and core lint failures due to + incorrect handling of join points (:ghc-ticket:`23952`). +- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`). +- Fix a bug where we could silently truncate 64 bit values to 32 bit on + 32 bit architectures. +- Fix a GHCi bug where a failure in the ``:add`` command would cause the + process to exit (:ghc-ticket:`24115`). +- Fix a bug causing suboptimal error messages for certain invalid cyclic + module graphs with hs-boot files (:ghc-ticket:`24196`). +- Fix a bug causing compiler panics with certain package databases involving + unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`, + :ghc-ticket:`11050`). +- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`, + :ghc-ticket:`24118`). +- Fix a bug leading to some template haskell splices failing on being reloaded + into GHCi due to not clearing the interactive context properly + (:ghc-ticket:`23405`). +- Fix a type checker crash on certain programs involving implicitly scoped type + 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`). + +Runtime system +-------------- + +- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`). +- Ensure the ``listAllBlocks`` function takes the non-moving heap into account + (:ghc-ticket:`22627`). +- Ensure the non-moving GC is not running when pausing +- Fix some non-moving loops and bugs on Windows and LLP64 platforms + (:ghc-ticket:`23003`, :ghc-ticket:`24042`). +- Fix a bug where certain programs could have incorrect async exception masking + (:ghc-ticket:`23513`). +- Ensure we respect maximum event length and don't overflow into program + memory (:ghc-ticket:`24197`). + +Build system and packaging +-------------------------- + +- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`, + :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`). + +Core libraries +-------------- + +- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in + out of bounds access (:ghc-ticket:`24066`). +- Bump ``base`` to 4.18.2.0 +- base: Update to Unicode 15.1.0 +- Bump ``filepath`` to 1.4.200.1 +- Bump ``unix`` to 2.8.4.0 +- Bump ``haddock`` to 2.29.2 + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + ===================================== docs/users_guide/release-notes.rst ===================================== @@ -7,3 +7,4 @@ Release notes 9.6.1-notes 9.6.2-notes 9.6.3-notes + 9.6.4-notes ===================================== hadrian/bindist/Makefile ===================================== @@ -92,6 +92,7 @@ lib/settings : config.mk @echo ',("ld flags", "$(SettingsLdFlags)")' >> $@ @echo ',("ld supports compact unwind", "$(LdHasNoCompactUnwind)")' >> $@ @echo ',("ld supports filelist", "$(LdHasFilelist)")' >> $@ + @echo ',("ld supports single module", "$(LdHasSingleModule)")' >> $@ @echo ',("ld is GNU ld", "$(LdIsGNULd)")' >> $@ @echo ',("Merge objects command", "$(SettingsMergeObjectsCommand)")' >> $@ @echo ',("Merge objects flags", "$(SettingsMergeObjectsFlags)")' >> $@ ===================================== hadrian/bindist/config.mk.in ===================================== @@ -240,6 +240,7 @@ LdHasBuildId = @LdHasBuildId@ LdHasFilelist = @LdHasFilelist@ LdIsGNULd = @LdIsGNULd@ LdHasNoCompactUnwind = @LdHasNoCompactUnwind@ +LdHasSingleModule = @LdHasSingleModule@ ArArgs = @ArArgs@ ArSupportsAtFile = @ArSupportsAtFile@ ArSupportsDashL = @ArSupportsDashL@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -141,6 +141,7 @@ gcc-extra-via-c-opts = @GccExtraViaCOpts@ ld-has-no-compact-unwind = @LdHasNoCompactUnwind@ ld-has-filelist = @LdHasFilelist@ ld-is-gnu-ld = @LdIsGNULd@ +ld-supports-single-module = @LdHasSingleModule@ ar-args = @ArArgs@ settings-c-compiler-command = @SettingsCCompilerCommand@ ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -430,6 +430,7 @@ generateSettings = do , ("ld supports compact unwind", expr $ lookupSystemConfig "ld-has-no-compact-unwind") , ("ld supports filelist", expr $ lookupSystemConfig "ld-has-filelist") , ("ld is GNU ld", expr $ lookupSystemConfig "ld-is-gnu-ld") + , ("ld supports single module", expr $ lookupSystemConfig "ld-supports-single-module") , ("Merge objects command", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsCommand) , ("Merge objects flags", expr $ settingsFileSetting SettingsFileSetting_MergeObjectsFlags) , ("ar command", expr $ settingsFileSetting SettingsFileSetting_ArCommand) ===================================== libraries/base/jsbits/base.js ===================================== @@ -826,8 +826,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== m4/fp_prog_ld_single_module.m4 ===================================== @@ -0,0 +1,30 @@ +# FP_PROG_LD_SINGLE_MODULE +# ---------------------------- +# Sets the output variable LdHasSingleModule to YES if the darwin ld supports +# -single_module, or NO otherwise. +# +# In XCode 15, -single_module is a default and passing it as a flag raises a +# warning. +AC_DEFUN([FP_PROG_LD_SINGLE_MODULE], +[ +AC_CACHE_CHECK([whether ld supports -single_module], [fp_cv_ld_single_module], +[ +case $target in + *-darwin) + echo 'int foo(int x) { return x*x; }' > conftest.c + echo 'extern int foo(int); int main() { return foo(5); }' > conftestmain.c + "$CC" -c -o conftestmain.o conftestmain.c + "$CC" -shared -o conftest.dylib conftest.c + if "$CC" -Wl,-single_module -o conftest conftestmain.o conftest.dylib 2>&1 | grep obsolete > /dev/null; then + fp_cv_ld_single_module=no + else + fp_cv_ld_single_module=yes + fi + rm -rf conftest* ;; + *) + fp_cv_ld_single_module=no ;; +esac +]) +FP_CAPITALIZE_YES_NO(["$fp_cv_ld_single_module"], [LdHasSingleModule]) +AC_SUBST([LdHasSingleModule]) +])# FP_PROG_LD_SINGLE_MODULE ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; + return true; +} ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_fail/all.T ===================================== @@ -24,4 +24,3 @@ check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length check_bounds_test('CheckOverlapCopyByteArray') check_bounds_test('CheckOverlapCopyAddrToByteArray') - ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,7 +229,7 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) # TODO: Enable more architectures here. N.B. some code generation backends are # not implemeted correctly (according to View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/862a225013247e09621164bcead3befcadb6ba17...3ce937a721e77accc8578d603d477e66a1c28931 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/862a225013247e09621164bcead3befcadb6ba17...3ce937a721e77accc8578d603d477e66a1c28931 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 Dec 18 15:10:43 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 10:10:43 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 2 commits: Fix remaining issues with bound checking (#23123) Message-ID: <658060f377ff4_e7a736df6bb583999ee@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: d86cd08b by Sylvain Henry at 2023-12-18T20:40:08+05:30 Fix remaining issues with bound checking (#23123) While fixing these I've also changed the way we store addresses into ByteArray#. Addr# are composed of two parts: a JavaScript array and an offset (32-bit number). Suppose we want to store an Addr# in a ByteArray# foo at offset i. Before this patch, we were storing both fields as a tuple in the "arr" array field: foo.arr[i] = [addr_arr, addr_offset]; Now we only store the array part in the "arr" field and the offset directly in the array: foo.dv.setInt32(i, addr_offset): foo.arr[i] = addr_arr; It avoids wasting space for the tuple. (cherry picked from commit 2d5c1ddecf195da9a8ee4f7b38fbb79d3b680aeb) - - - - - 92572153 by Zubin Duggal at 2023-12-18T20:40:08+05:30 Prepare release 9.6.4 - - - - - 12 changed files: - compiler/GHC/StgToJS/Linker/Utils.hs - compiler/GHC/StgToJS/Prim.hs - configure.ac - + docs/users_guide/9.6.4-notes.rst - docs/users_guide/release-notes.rst - libraries/base/jsbits/base.js - rts/js/environment.js - rts/js/mem.js - rts/js/profiling.js - rts/js/staticpointer.js - rts/js/string.js - testsuite/tests/codeGen/should_run/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Utils.hs ===================================== @@ -137,6 +137,10 @@ genCommonCppDefs profiling = mconcat then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + -- Put Addr# in ByteArray# or at Addr# (same thing) + , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + -- Data.Maybe.Maybe , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) -import Data.Maybe genPrim :: Bool -- ^ Profiling (cost-centres) enabled @@ -527,215 +526,202 @@ genPrim prof bound ty op = case op of ------------------------------ Arrays ------------------------------------------- - NewArrayOp -> \[r] [l,e] -> PrimInline (newArray r l e) - ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v) + NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] + ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] - FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] - CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ - jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] + PrimInline + $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound a2 o2 n + $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + + CloneArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + FreezeArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + PrimInline + $ bnd_arr_range bound a start n + $ r |= app "h$sliceArray" [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] + ] ------------------------------ Small Arrays ------------------------------------- NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked bound a i (a .! i |= e) + ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ - loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ appS "h$copyMutableArray" [s,si,d,di,n] + + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline + $ bnd_arr bound a i + $ jVar \x -> mconcat + [ x |= a .! i + , ifBlockS (x .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= x + ] ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] ------------------------------- Byte Arrays ------------------------------------- - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a i $ jVar \t -> mconcat - [ t |= a .^ "arr" - , ifBlockS (t .&&. t .! (i .<<. two_)) - [ r1 |= t .! (i .<<. two_) .! zero_ - , r2 |= t .! (i .<<. two_) .! one_ - ] - [ r1 |= null_ - , r2 |= zero_ - ] - ] + NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) + NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) + MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ + ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] + ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] + ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] + UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b + SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" + + IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_i32 a i - ] - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_i32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ h |= read_u32 a (Add (i .<<. one_) one_) - , l |= read_u32 a (i .<<. one_) - ] - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e2 - - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_i32 a (Add (i .<<. one_) one_) e1 - , write_u32 a (i .<<. one_) e2 - ] - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a (byteIndex64 i) $ mconcat - [ write_u32 a (Add (i .<<. one_) one_) h - , write_u32 a (i .<<. one_) l - ] CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n + PrimInline . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline . boundsCheckedRangeLen bound a1 o1 n - . boundsCheckedRangeLen bound a2 o2 n - . checkOverlapByteArray bound a1 o1 a2 o2 n - $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs - CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + -- We assume the arrays aren't overlapping since they're of different types + -- (ByteArray vs MutableByteArray, Addr# vs MutableByteArray#, [Mutable]ByteArray# vs Addr#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . boundsCheckedRangeLen bound a o n $ loopBlockS zero_ (.<. n) \i -> + PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> [ write_u8 a (Add o i) v , postIncrS i ] - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ fetchOpByteArray BXor r a i v + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v ------------------------------- Addr# ------------------------------------------ @@ -753,107 +739,58 @@ genPrim prof bound ty op = case op of ------------------------------- Addr Indexing: Unboxed Arrays ------------------- - IndexOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> - PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) - $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) - [ ca |= a .^ "arr" .! (off32 o i) .! zero_ - , co |= a .^ "arr" .! (off32 o i) .! one_ - ] - [ ca |= null_ - , co |= zero_ - ] - IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_i32 a (off32 o i) - ] - IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , l |= read_boff_u32 a (off64 o i) - ] - ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsChecked bound (a .^ "arr") (Add o x) $ - ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) - [ c1 |= a .^ "arr" .! (Add o x) .! zero_ - , c2 |= a .^ "arr" .! (Add o x) .! one_ - ] - [ c1 |= null_ - , c2 |= zero_ - ] - ] - ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat - [ c1 |= var "h$stablePtrBuf" - , c2 |= read_boff_u32 a (off32 o i) - ] - ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> - PrimInline $ mconcat - [ h |= read_i32 a (Add (off64 o i) (Int 4)) - , l |= read_u32 a (off64 o i) - ] - ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> - PrimInline $ mconcat - [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) - , c2 |= read_boff_u32 a (off64 o i) - ] - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsChecked bound (a .^ "arr") (off32 o i) $ - AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) - ] - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat - [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 - , write_boff_u32 a (off64 o i) v2 - ] --- Mutable variables + IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l + +------------------------------- Mutable varialbes -------------------------------------- NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x @@ -914,17 +851,17 @@ genPrim prof bound ty op = case op of ------------------------------- Concurrency Primitives ------------------------- - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l + ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) + ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument + KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) + YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) + MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" + IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ + NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing + ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] + ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] + GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] + LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l ------------------------------- Weak Pointers ----------------------------------- @@ -1028,184 +965,82 @@ genPrim prof bound ty op = case op of TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> - PrimInline $ jVar \x -> mconcat - [ x |= i .<<. two_ - , boundsCheckedLen bound (a .^ "arr") x $ - ifS (a .^ "arr" .&&. a .^ "arr" .! x) - (mconcat [ r1 |= a .^ "arr" .! x .! zero_ - , r2 |= a .^ "arr" .! x .! one_ - ]) - (mconcat [r1 |= null_, r2 |= one_]) - ] - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> - PrimInline $ mconcat - [ r1 |= var "h$stablePtrBuf" - , r2 |= read_boff_i32 a i - ] - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> - PrimInline $ mconcat - [ h |= read_boff_i32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ mconcat - [ h |= read_boff_u32 a (Add i (Int 4)) - , l |= read_boff_u32 a i - ] - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> - PrimInline $ mconcat - [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty - , boundsCheckedLen bound (a .^ "arr") (i .<<. two_) $ - a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) - ] - - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e2 - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> - -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i - -- then write the higher 4 bytes to i+4 - PrimInline . boundsCheckedLen bound a i - $ mconcat [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 1) $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> - PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 7) - $ mconcat [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsCheckedLen bound a i . boundsCheckedLen bound a (Add i 3) $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a i $ casOp read_i8 write_i8 r a i old new - CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex16 i) $ casOp read_i16 write_i16 r a i old new - CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsCheckedLen bound a (byteIndex32 i) $ casOp read_i32 write_i32 r a i old new - - CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsCheckedLen bound a (Add (i .<<. one_) one_) $ - jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) - , t_l |= read_u32 a (i .<<. one_) - , r_h |= t_h - , r_l |= t_l - , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast - (ifBlockS (t_h .===. old_h) - -- Pre-Condition is good, do the write - [ write_i32 a (Add (i .<<. one_) one_) new_h - , write_u32 a (i .<<. one_) new_l - ] - -- no good, don't write - mempty) - mempty - ] - - CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ - mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) - (appS "h$memcpy" [a3,o3,a1,o1,8]) - mempty - , r_a |= a1 - , r_o |= o1 - ] +------------------------------ ByteArray ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ - mconcat [ r_h |= read_u32 a (Add o (Int 4)) - , r_l |= read_u32 a o - , ifS (r_l .===. old_l) - (ifBlockS (r_h .===. old_h) - [ write_u32 a (Add o (Int 4)) new_h - , write_u32 a o new_l - ] - mempty) - mempty - ] - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - InterlockedExchange_Addr -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ - -- this primop can't be implemented - -- correctly because we don't store - -- the array reference part of an Addr#, - -- only the offset part. - -- - -- So let's assume that all the array - -- references are the same... - -- - -- Note: we could generate an assert - -- that checks that a1 === a2. However - -- we can't check that the Addr# read - -- at Addr# a2[o2] also comes from this - -- a1/a2 array. - mconcat [ r_a |= a1 -- might be wrong (see above) - , r_o |= read_boff_u32 a1 o1 - -- TODO (see above) - -- assert that a1 === a2 - , write_boff_u32 a1 o1 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ - mconcat [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" @@ -1364,6 +1199,79 @@ read_f32 a i = idx_f32 a i read_f64 :: JExpr -> JExpr -> JExpr read_f64 a i = idx_f64 a i +read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_u32 a (Add 1 (i .<<. 1)) + ] + +read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. 1) + , rh |= read_i32 a (Add 1 (i .<<. 1)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_addr a i r o = mconcat + [ write_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. 2) |= r + ] + +read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_addr a i r o = mconcat + [ o |= read_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) + (a .^ "arr" .! (i .<<. 2)) + null_ + ] + +read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_addr a i r o = mconcat + [ o |= read_boff_i32 a i + , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) + (a .^ "arr" .! i) + null_ + ] + +write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_addr a i r o = mconcat + [ write_boff_i32 a i o + -- create the hidden array for arrays if it doesn't exist + , ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! i |= r + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_i32 a i + ] + +read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_stableptr a i r o = mconcat + [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array + , o |= read_boff_i32 a i + ] + +write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + +write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf + write_u8 :: JExpr -> JExpr -> JExpr -> JStat write_u8 a i v = idx_u8 a i |= v @@ -1388,6 +1296,18 @@ write_f32 a i v = idx_f32 a i |= v write_f64 :: JExpr -> JExpr -> JExpr -> JStat write_f64 a i v = idx_f64 a i |= v +write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_u32 a (Add 1 (i .<<. 1)) h + ] + +write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. 1) l + , write_i32 a (Add 1 (i .<<. 1)) h + ] + -- Data View helper functions: byte indexed! -- -- The argument list consists of the array @a@, the index @i@, and the new value @@ -1403,6 +1323,16 @@ write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_] write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_] write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_] +write_boff_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr read_boff_i8 a i = read_i8 a i read_boff_u8 a i = read_u8 a i @@ -1413,6 +1343,18 @@ read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_] read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_] read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_] +read_boff_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat fetchOpByteArray op tgt src i v = mconcat [ tgt |= read_i32 src i @@ -1428,8 +1370,8 @@ fetchOpAddr op tgt src i v = mconcat casOp :: (JExpr -> JExpr -> JExpr) -- read -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source arrays + -> JExpr -- target register to store result + -> JExpr -- source array -> JExpr -- index -> JExpr -- old value to compare -> JExpr -- new value to write @@ -1441,73 +1383,151 @@ casOp read write tgt src i old new = mconcat mempty ] +casOp2 + :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read + -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write + -> (JExpr,JExpr) -- target registers to store result + -> JExpr -- source array + -> JExpr -- index + -> (JExpr,JExpr) -- old value to compare + -> (JExpr,JExpr) -- new value to write + -> JStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + -------------------------------------------------------------------------------- -- Lifted Arrays -------------------------------------------------------------------------------- -- | lifted arrays -cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat -cloneArray tgt src mb_offset len = mconcat - [ tgt |= ApplExpr (src .^ "slice") [start, end] - , tgt .^ closureMeta_ |= zero_ - , tgt .^ "__ghcjsArray" |= true_ - ] - where - start = fromMaybe zero_ mb_offset - end = maybe len (Add len) mb_offset - -newArray :: JExpr -> JExpr -> JExpr -> JStat -newArray tgt len elem = - tgt |= app "h$newArray" [len, elem] +cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat +cloneArray bound_check tgt src start len = + bnd_arr_range bound_check src start len + $ mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, Add len start] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] newByteArray :: JExpr -> JExpr -> JStat newByteArray tgt len = tgt |= app "h$newByteArray" [len] -boundsChecked' +-- | Check that index is positive and below a max value. Halt the process with +-- error code 134 otherwise. This is used to implement -fcheck-prim-bounds +check_bound :: JExpr -- ^ Max index expression -> Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsChecked' _ False _ r = r -boundsChecked' max_index True i r = - ifS ((i .>=. zero_) .&&. (i .<. max_index)) r $ - returnS (app "h$exitProcess" [Int 134]) +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app "h$exitProcess" [Int 134]) + , r + ] -- | Bounds checking using ".length" property (Arrays) -boundsChecked +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +bnd_arr do_check arr = check_bound (arr .^ "length") do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index + -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsChecked do_check arr = boundsChecked' (arr .^ "length") do_check +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) -- | Bounds checking using ".len" property (ByteArrays) -boundsCheckedLen +bnd_ba :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JStat -- ^ Result -> JStat -boundsCheckedLen do_check arr = boundsChecked' (arr .^ "len") do_check +bnd_ba do_check arr = check_bound (arr .^ "len") do_check + +-- | ByteArray bounds checking (byte offset, 8-bit value) +bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 1) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 3) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx 7) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r -- | Bounds checking on a range and using ".len" property (ByteArrays) -- -- Empty ranges trivially pass the check -boundsCheckedRangeLen +bnd_ba_range :: Bool -- ^ Should we do bounds checking? -> JExpr -- ^ Array -> JExpr -- ^ Index -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -boundsCheckedRangeLen False _ _ _ r = r -boundsCheckedRangeLen True xs i n r = +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ - ifS (n .===. zero_) -- We can always fill zero elements, even if it seems out-of-bounds + -- Empty ranges trivially pass the check + ifS (n .===. zero_) r - (boundsCheckedLen True xs (Add i (Sub n 1)) (boundsCheckedLen True xs i r)) + (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) checkOverlapByteArray :: Bool -- ^ Should we do bounds checking? @@ -1518,20 +1538,18 @@ checkOverlapByteArray -> JExpr -- ^ Range size -> JStat -- ^ Result -> JStat -checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray False _ _ _ _ _ r = r checkOverlapByteArray True a1 o1 a2 o2 n r = ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) r (returnS $ app "h$exitProcess" [Int 134]) -byteIndex16 :: JExpr -> JExpr -byteIndex16 i = Add 1 (Mul 2 i) - -byteIndex32 :: JExpr -> JExpr -byteIndex32 i = Add 3 (Mul 4 i) - -byteIndex64 :: JExpr -> JExpr -byteIndex64 i = Add 7 (Mul 8 i) +copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes +copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) -- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 -- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -0,0 +1,123 @@ +.. _release-9-6-4: + +Version 9.6.4 +============== + +The significant changes to the various parts of the compiler are listed below. +See the `migration guide +`_ on the GHC Wiki +for specific guidance on migrating programs to this release. + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM +11, 12, 13, 14 or 15. + +Significant Changes +~~~~~~~~~~~~~~~~~~~~ + +Issues fixed in this release include: + +Compiler +-------- + +- Fix a code generator bug on AArch64 platforms resulting in invalid conditional + jumps (:ghc-ticket:`23746`). +- Fix a simplifier bug that may cause segfaults and core lint failures due to + incorrect handling of join points (:ghc-ticket:`23952`). +- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`). +- Fix a bug where we could silently truncate 64 bit values to 32 bit on + 32 bit architectures. +- Fix a GHCi bug where a failure in the ``:add`` command would cause the + process to exit (:ghc-ticket:`24115`). +- Fix a bug causing suboptimal error messages for certain invalid cyclic + module graphs with hs-boot files (:ghc-ticket:`24196`). +- Fix a bug causing compiler panics with certain package databases involving + unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`, + :ghc-ticket:`11050`). +- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`, + :ghc-ticket:`24118`). +- Fix a bug leading to some template haskell splices failing on being reloaded + into GHCi due to not clearing the interactive context properly + (:ghc-ticket:`23405`). +- Fix a type checker crash on certain programs involving implicitly scoped type + 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`). + +Runtime system +-------------- + +- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`). +- Ensure the ``listAllBlocks`` function takes the non-moving heap into account + (:ghc-ticket:`22627`). +- Ensure the non-moving GC is not running when pausing +- Fix some non-moving loops and bugs on Windows and LLP64 platforms + (:ghc-ticket:`23003`, :ghc-ticket:`24042`). +- Fix a bug where certain programs could have incorrect async exception masking + (:ghc-ticket:`23513`). +- Ensure we respect maximum event length and don't overflow into program + memory (:ghc-ticket:`24197`). + +Build system and packaging +-------------------------- + +- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`, + :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`). + +Core libraries +-------------- + +- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in + out of bounds access (:ghc-ticket:`24066`). +- Bump ``base`` to 4.18.2.0 +- base: Update to Unicode 15.1.0 +- Bump ``filepath`` to 1.4.200.1 +- Bump ``unix`` to 2.8.4.0 +- Bump ``haddock`` to 2.29.2 + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + ===================================== docs/users_guide/release-notes.rst ===================================== @@ -7,3 +7,4 @@ Release notes 9.6.1-notes 9.6.2-notes 9.6.3-notes + 9.6.4-notes ===================================== libraries/base/jsbits/base.js ===================================== @@ -826,8 +826,7 @@ function h$__hscore_readdir(d,o,dst_a,dst_o) { } const e = d.readSync(); - if (!dst_a.arr) dst_a.arr = []; - dst_a.arr[dst_o*2] = [e,0]; + PUT_ADDR(dst_a,dst_o*2,e,0); return 0; } ===================================== rts/js/environment.js ===================================== @@ -158,20 +158,19 @@ function h$getProgArgv(argc_v,argc_off,argv_v,argv_off) { } else { argc_v.dv.setInt32(argc_off, c, true); var argv = h$newByteArray(4*c); - argv.arr = []; for(var i=0;i=0;i--) { + a2.arr[o2+i] = a1.arr[o1+i] || null; + } + } else { + for (var i=0;i= n; + if (o1 > o2) return o1 - o2 >= n; return true; } ===================================== rts/js/profiling.js ===================================== @@ -302,10 +302,9 @@ function h$buildCCPtr(o) { #ifdef GHCJS_TRACE_PROF cc.myTag = "cc pointer"; #endif - cc.arr = []; - cc.arr[h$ccLabel_offset] = [h$encodeUtf8(o.label), 0]; - cc.arr[h$ccModule_offset] = [h$encodeUtf8(o.module), 0]; - cc.arr[h$ccsrcloc_offset] = [h$encodeUtf8(o.srcloc), 0]; + PUT_ADDR(cc, h$ccLabel_offset, h$encodeUtf8(o.label), 0); + PUT_ADDR(cc, h$ccModule_offset, h$encodeUtf8(o.module), 0); + PUT_ADDR(cc, h$ccsrcloc_offset, h$encodeUtf8(o.srcloc), 0); return cc; } ===================================== rts/js/staticpointer.js ===================================== @@ -16,7 +16,7 @@ function h$hs_spt_insert(key1,key2,key3,key4,ref) { ba.i3[1] = key1; ba.i3[2] = key4; ba.i3[3] = key3; - h$static_pointer_table_keys.push([ba,0]); + h$static_pointer_table_keys.push(ba); h$retain({ root: ref, _key: -1 }); } var s = h$static_pointer_table; @@ -33,8 +33,9 @@ function h$hs_spt_key_count() { function h$hs_spt_keys(tgt_d, tgt_o, n) { var ks = h$static_pointer_table_keys; - if(!tgt_d.arr) tgt_d.arr = []; - for(var i=0;(i ptr (array) -function h$derefPtrA(ptr, ptr_off) { - return ptr.arr[ptr_off][0]; -} -// ptr* -> ptr (offset) -function h$derefPtrO(ptr, ptr_off) { - return ptr.arr[ptr_off][1]; -} - -// word** -> word ptr[x][y] -function h$readPtrPtrU32(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getInt32(arr[1] + 4 * y, true); -} - -// char** -> char ptr[x][y] -function h$readPtrPtrU8(ptr, ptr_off, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - return arr[0].dv.getUint8(arr[1] + y); -} - -// word** ptr[x][y] = v -function h$writePtrPtrU32(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off + 4 * x]; - arr[0].dv.putInt32(arr[1] + y, v); -} - -// unsigned char** ptr[x][y] = v -function h$writePtrPtrU8(ptr, ptr_off, v, x, y) { - x = x || 0; - y = y || 0; - var arr = ptr.arr[ptr_off+ 4 * x]; - arr[0].dv.putUint8(arr[1] + y, v); -} - // convert JavaScript String to a Haskell String #ifdef GHCJS_PROF function h$toHsString(str, cc) { ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -229,7 +229,7 @@ test('T20640b', normal, compile_and_run, ['']) test('T22296',[only_ways(llvm_ways) ,unless(arch('x86_64'), skip)],compile_and_run,['']) test('T22798', normal, compile_and_run, ['-fregs-graph']) -test('CheckBoundsOK', js_broken(21142), compile_and_run, ['-fcheck-prim-bounds']) +test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds']) # TODO: Enable more architectures here. N.B. some code generation backends are # not implemeted correctly (according to View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ce937a721e77accc8578d603d477e66a1c28931...92572153b5ddda7ea3c6b77c3dd066f0124dfc48 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3ce937a721e77accc8578d603d477e66a1c28931...92572153b5ddda7ea3c6b77c3dd066f0124dfc48 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 Dec 18 16:01:34 2023 From: gitlab at gitlab.haskell.org (Marge Bot (@marge-bot)) Date: Mon, 18 Dec 2023 11:01:34 -0500 Subject: [Git][ghc/ghc][wip/marge_bot_batch_merge_job] GHCi: fix improper location of ghci_history file Message-ID: <65806cdedb854_e7a736f67d5584213cf@gitlab.mail> Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 5d8e3533 by ur4t at 2023-12-18T11:01:02-05:00 GHCi: fix improper location of ghci_history file Fixes #24266 - - - - - 1 changed file: - ghc/GHCi/UI.hs Changes: ===================================== ghc/GHCi/UI.hs ===================================== @@ -639,30 +639,27 @@ ghciLogAction lastErrLocations old_log_action _ -> return () _ -> return () --- | Takes a file name and prefixes it with the appropriate --- GHC appdir. --- Uses ~/.ghc (getAppUserDataDirectory) if it exists --- If it doesn't, then it uses $XDG_DATA_HOME/ghc --- Earlier we always used to use ~/.ghc, but we want --- to gradually move to $XDG_DATA_HOME to respect the XDG specification --- --- As a migration strategy, we will only create new directories in --- the appropriate XDG location. However, we will use the old directory --- if it already exists. -getAppDataFile :: FilePath -> IO (Maybe FilePath) -getAppDataFile file = do - let new_path = tryIO (getXdgDirectory XdgConfig "ghc") >>= \case - Left _ -> pure Nothing - Right dir -> flip catchIO (const $ return Nothing) $ do - createDirectoryIfMissing False dir - pure $ Just $ dir file - - e_old_path <- tryIO (getAppUserDataDirectory "ghc") - case e_old_path of - Right old_path -> doesDirectoryExist old_path >>= \case - True -> pure $ Just $ old_path file - False -> new_path - Left _ -> new_path +-- | Takes a file name and prefixes it with the appropriate GHC appdir. +-- ~/.ghc (getAppUserDataDirectory) is used if it exists, or XDG directories +-- are used to respect the XDG specification. +-- As a migration strategy, currently we will only create new directories in +-- the appropriate XDG location. +getAppDataFile :: XdgDirectory -> FilePath -> IO (Maybe FilePath) +getAppDataFile xdgDir file = do + xdgAppDir <- + tryIO (getXdgDirectory xdgDir "ghc") >>= \case + Left _ -> pure Nothing + Right dir -> flip catchIO (const $ pure Nothing) $ do + createDirectoryIfMissing False dir + pure $ Just dir + appDir <- + tryIO (getAppUserDataDirectory "ghc") >>= \case + Right dir -> + doesDirectoryExist dir >>= \case + True -> pure $ Just dir + False -> pure xdgAppDir + Left _ -> pure xdgAppDir + pure $ appDir >>= \dir -> Just $ dir file runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do @@ -670,13 +667,12 @@ runGHCi paths maybe_exprs = do let ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags - app_user_dir = liftIO $ getAppDataFile "ghci.conf" + appDataCfg = liftIO $ getAppDataFile XdgConfig "ghci.conf" - home_dir = do - either_dir <- liftIO $ tryIO (getEnv "HOME") - case either_dir of - Right home -> return (Just (home ".ghci")) - _ -> return Nothing + homeCfg = do + liftIO $ tryIO (getEnv "HOME") >>= \case + Right home -> pure $ Just $ home ".ghci" + _ -> pure Nothing canonicalizePath' :: FilePath -> IO (Maybe FilePath) canonicalizePath' fp = liftM Just (canonicalizePath fp) @@ -710,7 +706,7 @@ runGHCi paths maybe_exprs = do then pure [] else do userCfgs <- do - paths <- catMaybes <$> sequence [ app_user_dir, home_dir ] + paths <- catMaybes <$> sequence [ appDataCfg, homeCfg ] checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths @@ -797,12 +793,12 @@ runGHCiInput f = do dflags <- getDynFlags let ghciHistory = gopt Opt_GhciHistory dflags let localGhciHistory = gopt Opt_LocalGhciHistory dflags - currentDirectory <- liftIO $ getCurrentDirectory + currentDirectory <- liftIO getCurrentDirectory histFile <- case (ghciHistory, localGhciHistory) of - (True, True) -> return (Just (currentDirectory ".ghci_history")) - (True, _) -> liftIO $ getAppDataFile "ghci_history" - _ -> return Nothing + (True, True) -> pure $ Just $ currentDirectory ".ghci_history" + (True, _) -> liftIO $ getAppDataFile XdgData "ghci_history" + _ -> pure Nothing runInputT (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d8e35333f12ae6b05a16d7803ff6dc15937c36f -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d8e35333f12ae6b05a16d7803ff6dc15937c36f 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 Dec 18 17:54:53 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 18 Dec 2023 12:54:53 -0500 Subject: [Git][ghc/ghc] Pushed new branch wip/T24267 Message-ID: <6580876d10d82_e7a73725f1d0c4321ea@gitlab.mail> Krzysztof Gogolewski pushed new branch wip/T24267 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T24267 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 Dec 18 18:02:18 2023 From: gitlab at gitlab.haskell.org (Zubin (@wz1000)) Date: Mon, 18 Dec 2023 13:02:18 -0500 Subject: [Git][ghc/ghc][wip/9.6.4-backports] 2 commits: testsuite: Fix T21097b test with make 4.1 (deb9) Message-ID: <6580892ab4bba_e7a737272d2c04356e@gitlab.mail> Zubin pushed to branch wip/9.6.4-backports at Glasgow Haskell Compiler / GHC Commits: 34e8cf3c by Matthew Pickering at 2023-12-18T23:29:39+05:30 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. (cherry picked from commit bad3765668cc5badf5d0a19100fac95125985473) - - - - - 908c485f by Zubin Duggal at 2023-12-18T23:29:42+05:30 Prepare release 9.6.4 Metric Decrease: T13701 - - - - - 5 changed files: - configure.ac - + docs/users_guide/9.6.4-notes.rst - docs/users_guide/release-notes.rst - testsuite/tests/driver/T21097b/T21097b.stdout - testsuite/tests/driver/T21097b/all.T Changes: ===================================== configure.ac ===================================== @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.4], [glasgow-haskell-bugs at haskell.org], [ghc-AC_PACKAGE_VERSION]) # Version on master must be X.Y (not X.Y.Z) for ProjectVersionMunged variable # to be useful (cf #19058). However, the version must have three components # (X.Y.Z) on stable branches (e.g. ghc-9.2) to ensure that pre-releases are @@ -22,7 +22,7 @@ AC_INIT([The Glorious Glasgow Haskell Compilation System], [9.6.3], [glasgow-has AC_CONFIG_MACRO_DIRS([m4]) # Set this to YES for a released version, otherwise NO -: ${RELEASE=NO} +: ${RELEASE=YES} # The primary version (e.g. 7.5, 7.4.1) is set in the AC_INIT line # above. If this is not a released version, then we will append the ===================================== docs/users_guide/9.6.4-notes.rst ===================================== @@ -0,0 +1,123 @@ +.. _release-9-6-4: + +Version 9.6.4 +============== + +The significant changes to the various parts of the compiler are listed below. +See the `migration guide +`_ on the GHC Wiki +for specific guidance on migrating programs to this release. + +The :ghc-flag:`LLVM backend <-fllvm>` of this release is to be used with LLVM +11, 12, 13, 14 or 15. + +Significant Changes +~~~~~~~~~~~~~~~~~~~~ + +Issues fixed in this release include: + +Compiler +-------- + +- Fix a code generator bug on AArch64 platforms resulting in invalid conditional + jumps (:ghc-ticket:`23746`). +- Fix a simplifier bug that may cause segfaults and core lint failures due to + incorrect handling of join points (:ghc-ticket:`23952`). +- Ensure unconstrained instance dictionaries get IPE info (:ghc-ticket:`24005`). +- Fix a bug where we could silently truncate 64 bit values to 32 bit on + 32 bit architectures. +- Fix a GHCi bug where a failure in the ``:add`` command would cause the + process to exit (:ghc-ticket:`24115`). +- Fix a bug causing suboptimal error messages for certain invalid cyclic + module graphs with hs-boot files (:ghc-ticket:`24196`). +- Fix a bug causing compiler panics with certain package databases involving + unusable units and module reexports (:ghc-ticket:`21097`, :ghc-ticket:`16996`, + :ghc-ticket:`11050`). +- Fix some memory leaks in GHCi that manifest on reloads (:ghc-ticket:`24107`, + :ghc-ticket:`24118`). +- Fix a bug leading to some template haskell splices failing on being reloaded + into GHCi due to not clearing the interactive context properly + (:ghc-ticket:`23405`). +- Fix a type checker crash on certain programs involving implicitly scoped type + 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`). + +Runtime system +-------------- + +- Ensure concurrent thunk update is sound (:ghc-ticket:`23185`). +- Ensure the ``listAllBlocks`` function takes the non-moving heap into account + (:ghc-ticket:`22627`). +- Ensure the non-moving GC is not running when pausing +- Fix some non-moving loops and bugs on Windows and LLP64 platforms + (:ghc-ticket:`23003`, :ghc-ticket:`24042`). +- Fix a bug where certain programs could have incorrect async exception masking + (:ghc-ticket:`23513`). +- Ensure we respect maximum event length and don't overflow into program + memory (:ghc-ticket:`24197`). + +Build system and packaging +-------------------------- + +- Ensure we use the right linker flags on AArch64 darwin (:ghc-ticket:`21712`, + :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`). + +Core libraries +-------------- + +- Fix a bug in ghc-bignum where usage of `bigNatIsPowerOf2` might result in + out of bounds access (:ghc-ticket:`24066`). +- Bump ``base`` to 4.18.2.0 +- base: Update to Unicode 15.1.0 +- Bump ``filepath`` to 1.4.200.1 +- Bump ``unix`` to 2.8.4.0 +- Bump ``haddock`` to 2.29.2 + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + ===================================== docs/users_guide/release-notes.rst ===================================== @@ -7,3 +7,4 @@ Release notes 9.6.1-notes 9.6.2-notes 9.6.3-notes + 9.6.4-notes ===================================== testsuite/tests/driver/T21097b/T21097b.stdout ===================================== @@ -1,5 +1 @@ - -==================== Module Map ==================== Foo a-0.1 (exposed package) - - ===================================== testsuite/tests/driver/T21097b/all.T ===================================== @@ -1,6 +1,15 @@ +def normalise_t21097b_output(s): + res = "" + for l in s.splitlines(): + if 'Foo' in l: + res += l + res += "\n" + return res + # Package b is unusable (broken dependency) and reexport Foo from a (which is usable) test('T21097b', [ extra_files(["pkgdb", "pkgdb/a.conf", "pkgdb/b.conf", "Test.hs"]) , ignore_stderr + , normalise_fun(normalise_t21097b_output) , exit_code(2) ], makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92572153b5ddda7ea3c6b77c3dd066f0124dfc48...908c485f27b62961cb2798a373958f5c73734beb -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92572153b5ddda7ea3c6b77c3dd066f0124dfc48...908c485f27b62961cb2798a373958f5c73734beb 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 Dec 18 18:09:28 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 18 Dec 2023 13:09:28 -0500 Subject: [Git][ghc/ghc][wip/T24267] Turn -Wtype-equality-out-of-scope on by default Message-ID: <65808ad82cc9d_e7a73729fd9c8436117@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T24267 at Glasgow Haskell Compiler / GHC Commits: ba1d1715 by Krzysztof Gogolewski at 2023-12-18T19:09:19+01:00 Turn -Wtype-equality-out-of-scope on by default Also remove -Wnoncanonical-{monoid,monad}-instances from -Wcompat, since they are enabled by default. Refresh wcompat-warnings/ test with new -Wcompat warnings. Part of #24267 - - - - - 10 changed files: - compiler/GHC/Driver/Flags.hs - docs/users_guide/using-warnings.rst - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/warnings/should_compile/T18862b.hs - testsuite/tests/warnings/should_compile/T18862b.stderr - + testsuite/tests/warnings/should_compile/WarnNoncanonical.hs - + testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr - testsuite/tests/warnings/should_compile/all.T - testsuite/tests/wcompat-warnings/Template.hs - testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -952,7 +952,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnBadlyStagedTypes, Opt_WarnTypeEqualityRequiresOperators, Opt_WarnInconsistentFlags, - Opt_WarnDataKindsTC + Opt_WarnDataKindsTC, + Opt_WarnTypeEqualityOutOfScope ] -- | Things you get with -W @@ -1002,10 +1003,7 @@ minusWeverythingOpts = [ toEnum 0 .. ] minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports - , Opt_WarnTypeEqualityOutOfScope , Opt_WarnImplicitRhsQuantification , Opt_WarnDeprecatedTypeAbstractions ] ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -78,8 +78,11 @@ as ``-Wno-...`` for every individual warning in the group. * :ghc-flag:`-Wforall-identifier` * :ghc-flag:`-Wgadt-mono-local-binds` * :ghc-flag:`-Wtype-equality-requires-operators` + * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wbadly-staged-types` * :ghc-flag:`-Winconsistent-flags` + * :ghc-flag:`-Wnoncanonical-monoid-instances` + * :ghc-flag:`-Wnoncanonical-monad-instances` .. ghc-flag:: -W :shortdesc: enable normal warnings @@ -166,10 +169,7 @@ as ``-Wno-...`` for every individual warning in the group. :columns: 3 * :ghc-flag:`-Wsemigroup` - * :ghc-flag:`-Wnoncanonical-monoid-instances` - * :ghc-flag:`-Wnoncanonical-monad-instances` * :ghc-flag:`-Wcompat-unqualified-imports` - * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wimplicit-rhs-quantification` * :ghc-flag:`-Wdeprecated-type-abstractions` @@ -591,8 +591,6 @@ of ``-W(no-)*``. * Warn if ``pure`` is defined backwards (i.e. ``pure = return``). * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wnoncanonical-monadfail-instances :shortdesc: *(deprecated)* warn when ``Monad`` or ``MonadFail`` instances have @@ -636,8 +634,6 @@ of ``-W(no-)*``. * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wmissing-monadfail-instances :shortdesc: *(deprecated)* Warn when a failable pattern is used in a do-block that does @@ -2379,6 +2375,7 @@ of ``-W(no-)*``. :reverse: -Wno-type-equality-out-of-scope :since: 9.4.1 + :default: on In accordance with `GHC Proposal #371 `__, @@ -2395,9 +2392,6 @@ of ``-W(no-)*``. custom Prelude. In this case, consider updating your custom Prelude to re-export ``~`` from ``Data.Type.Equality``. - Being part of the :ghc-flag:`-Wcompat` option group, this warning is off by - default, but will be switched on in a future GHC release. - .. ghc-flag:: -Wtype-equality-requires-operators :shortdesc: warn when type equality ``a ~ b`` is used despite being out of scope :type: dynamic ===================================== testsuite/tests/ghci/scripts/ghci024.stdout ===================================== @@ -6,7 +6,6 @@ GHCi-specific dynamic flag settings: other dynamic, non-language, flag settings: -fno-diagnostics-show-caret -fno-dump-with-ways - -fexternal-dynamic-refs -fignore-optim-changes -fignore-hpc-changes -fno-ghci-history @@ -18,7 +17,6 @@ other dynamic, non-language, flag settings: warning settings: -Wsemigroup -Wcompat-unqualified-imports - -Wtype-equality-out-of-scope -Wimplicit-rhs-quantification -Wdeprecated-type-abstractions ~~~~~~~~~~ Testing :set -a ===================================== testsuite/tests/warnings/should_compile/T18862b.hs ===================================== @@ -1,4 +1,4 @@ -{-# OPTIONS -Wcompat -Wno-error=type-equality-out-of-scope #-} +{-# OPTIONS -Wno-error=type-equality-out-of-scope #-} module T18862b where ===================================== testsuite/tests/warnings/should_compile/T18862b.stderr ===================================== @@ -1,5 +1,5 @@ -T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wcompat)] +T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wdefault)] • The ‘~’ operator is out of scope. Assuming it to stand for an equality constraint. • NB: ‘~’ used to be built-in syntax but now is a regular type operator ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.hs ===================================== @@ -0,0 +1,30 @@ +module WarnNoncanonical where + +import qualified Data.Semigroup as Semi + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 + +newtype M a = M a + +instance Functor M where + fmap = undefined + +instance Applicative M where + liftA2 = undefined + pure = return + (*>) = (>>) + +instance Monad M where + return = undefined + (>>=) = undefined + (>>) = undefined ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr ===================================== @@ -0,0 +1,45 @@ + +WarnNoncanonical.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘(<>) = mappend’ definition detected + in the instance declaration for ‘Semigroup S’. + Suggested fix: + Move definition from ‘mappend’ to ‘(<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘mappend’ definition detected + in the instance declaration for ‘Monoid S’. + ‘mappend’ will eventually be removed in favour of ‘(<>)’ + Suggested fix: + Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘pure = return’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘return’ to ‘pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(*>) = (>>)’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘(>>)’ to ‘(*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘return’ definition detected + in the instance declaration for ‘Monad M’. + ‘return’ will eventually be removed in favour of ‘pure’ + Suggested fix: + Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(>>)’ definition detected + in the instance declaration for ‘Monad M’. + ‘(>>)’ will eventually be removed in favour of ‘(*>)’ + Suggested fix: + Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -68,3 +68,4 @@ test('T22702b', normal, compile, ['']) test('T22826', normal, compile, ['']) test('T23573', [extra_files(["T23573.hs", "T23573A.hs", "T23573B.hs"])], multimod_compile, ['T23573', '-v0']) test('T23465', normal, compile, ['-ddump-parsed']) +test('WarnNoncanonical', normal, compile, ['']) ===================================== testsuite/tests/wcompat-warnings/Template.hs ===================================== @@ -1,30 +1,13 @@ +{-# LANGUAGE DataKinds #-} module WCompatWarningsOnOff where -import qualified Data.Semigroup as Semi +import Data.Proxy +import GHC.Types +import Data.List +import Data.Kind -(<>) = undefined -- Semigroup warnings +type T1 = 'Nothing :: Maybe a --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 - -newtype M a = M a - -instance Functor M where - fmap = undefined - -instance Applicative M where - liftA2 = undefined - pure = return - (*>) = (>>) - -instance Monad M where - return = undefined - (>>=) = undefined - (>>) = undefined +foo :: Maybe a -> Maybe a +foo (Just @b x) = Just @b x +foo _ = Nothing ===================================== testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr ===================================== @@ -1,45 +1,15 @@ -Template.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(<>) = mappend’ definition detected - in the instance declaration for ‘Semigroup S’. - Suggested fix: - Move definition from ‘mappend’ to ‘(<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘mappend’ definition detected - in the instance declaration for ‘Monoid S’. - ‘mappend’ will eventually be removed in favour of ‘(<>)’ - Suggested fix: - Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘pure = return’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘return’ to ‘pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(*>) = (>>)’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘(>>)’ to ‘(*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘return’ definition detected - in the instance declaration for ‘Monad M’. - ‘return’ will eventually be removed in favour of ‘pure’ - Suggested fix: - Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(>>)’ definition detected - in the instance declaration for ‘Monad M’. - ‘(>>)’ will eventually be removed in favour of ‘(*>)’ - Suggested fix: - Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return +Template.hs:6:8: warning: [GHC-82347] [-Wcompat-unqualified-imports (in -Wcompat)] + To ensure compatibility with future core libraries changes + imports to Data.List should be + either qualified or have an explicit import list. + +Template.hs:9:29: warning: [GHC-16382] [-Wimplicit-rhs-quantification (in -Wcompat)] + The variable ‘a’ occurs free on the RHS of the type declaration + In the future GHC will no longer implicitly quantify over such variables + Suggested fix: Bind ‘a’ on the LHS of the type declaration + +Template.hs:12:6: warning: [GHC-69797] [-Wdeprecated-type-abstractions (in -Wcompat)] + Type applications in constructor patterns will require + the TypeAbstractions extension starting from GHC 9.14. + Suggested fix: Perhaps you intended to use TypeAbstractions View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba1d17152981ffbd21142ebc61496477746fb949 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba1d17152981ffbd21142ebc61496477746fb949 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 Dec 18 18:13:49 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 18 Dec 2023 13:13:49 -0500 Subject: [Git][ghc/ghc][wip/T24267] Turn -Wtype-equality-out-of-scope on by default Message-ID: <65808bdddd077_e7a7372979588436419@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T24267 at Glasgow Haskell Compiler / GHC Commits: 5a7a1c02 by Krzysztof Gogolewski at 2023-12-18T19:13:33+01:00 Turn -Wtype-equality-out-of-scope on by default Also remove -Wnoncanonical-{monoid,monad}-instances from -Wcompat, since they are enabled by default. Refresh wcompat-warnings/ test with new -Wcompat warnings. Part of #24267 - - - - - 10 changed files: - compiler/GHC/Driver/Flags.hs - docs/users_guide/using-warnings.rst - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/warnings/should_compile/T18862b.hs - testsuite/tests/warnings/should_compile/T18862b.stderr - + testsuite/tests/warnings/should_compile/WarnNoncanonical.hs - + testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr - testsuite/tests/warnings/should_compile/all.T - testsuite/tests/wcompat-warnings/Template.hs - testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -952,7 +952,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnBadlyStagedTypes, Opt_WarnTypeEqualityRequiresOperators, Opt_WarnInconsistentFlags, - Opt_WarnDataKindsTC + Opt_WarnDataKindsTC, + Opt_WarnTypeEqualityOutOfScope ] -- | Things you get with -W @@ -1002,10 +1003,7 @@ minusWeverythingOpts = [ toEnum 0 .. ] minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports - , Opt_WarnTypeEqualityOutOfScope , Opt_WarnImplicitRhsQuantification , Opt_WarnDeprecatedTypeAbstractions ] ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -78,8 +78,12 @@ as ``-Wno-...`` for every individual warning in the group. * :ghc-flag:`-Wforall-identifier` * :ghc-flag:`-Wgadt-mono-local-binds` * :ghc-flag:`-Wtype-equality-requires-operators` + * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wbadly-staged-types` * :ghc-flag:`-Winconsistent-flags` + * :ghc-flag:`-Wnoncanonical-monoid-instances` + * :ghc-flag:`-Wnoncanonical-monad-instances` + * :ghc-flag:`-Wdata-kinds-tc` .. ghc-flag:: -W :shortdesc: enable normal warnings @@ -166,10 +170,7 @@ as ``-Wno-...`` for every individual warning in the group. :columns: 3 * :ghc-flag:`-Wsemigroup` - * :ghc-flag:`-Wnoncanonical-monoid-instances` - * :ghc-flag:`-Wnoncanonical-monad-instances` * :ghc-flag:`-Wcompat-unqualified-imports` - * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wimplicit-rhs-quantification` * :ghc-flag:`-Wdeprecated-type-abstractions` @@ -591,8 +592,6 @@ of ``-W(no-)*``. * Warn if ``pure`` is defined backwards (i.e. ``pure = return``). * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wnoncanonical-monadfail-instances :shortdesc: *(deprecated)* warn when ``Monad`` or ``MonadFail`` instances have @@ -636,8 +635,6 @@ of ``-W(no-)*``. * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wmissing-monadfail-instances :shortdesc: *(deprecated)* Warn when a failable pattern is used in a do-block that does @@ -2379,6 +2376,7 @@ of ``-W(no-)*``. :reverse: -Wno-type-equality-out-of-scope :since: 9.4.1 + :default: on In accordance with `GHC Proposal #371 `__, @@ -2395,9 +2393,6 @@ of ``-W(no-)*``. custom Prelude. In this case, consider updating your custom Prelude to re-export ``~`` from ``Data.Type.Equality``. - Being part of the :ghc-flag:`-Wcompat` option group, this warning is off by - default, but will be switched on in a future GHC release. - .. ghc-flag:: -Wtype-equality-requires-operators :shortdesc: warn when type equality ``a ~ b`` is used despite being out of scope :type: dynamic ===================================== testsuite/tests/ghci/scripts/ghci024.stdout ===================================== @@ -6,7 +6,6 @@ GHCi-specific dynamic flag settings: other dynamic, non-language, flag settings: -fno-diagnostics-show-caret -fno-dump-with-ways - -fexternal-dynamic-refs -fignore-optim-changes -fignore-hpc-changes -fno-ghci-history @@ -18,7 +17,6 @@ other dynamic, non-language, flag settings: warning settings: -Wsemigroup -Wcompat-unqualified-imports - -Wtype-equality-out-of-scope -Wimplicit-rhs-quantification -Wdeprecated-type-abstractions ~~~~~~~~~~ Testing :set -a ===================================== testsuite/tests/warnings/should_compile/T18862b.hs ===================================== @@ -1,4 +1,4 @@ -{-# OPTIONS -Wcompat -Wno-error=type-equality-out-of-scope #-} +{-# OPTIONS -Wno-error=type-equality-out-of-scope #-} module T18862b where ===================================== testsuite/tests/warnings/should_compile/T18862b.stderr ===================================== @@ -1,5 +1,5 @@ -T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wcompat)] +T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wdefault)] • The ‘~’ operator is out of scope. Assuming it to stand for an equality constraint. • NB: ‘~’ used to be built-in syntax but now is a regular type operator ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.hs ===================================== @@ -0,0 +1,30 @@ +module WarnNoncanonical where + +import qualified Data.Semigroup as Semi + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 + +newtype M a = M a + +instance Functor M where + fmap = undefined + +instance Applicative M where + liftA2 = undefined + pure = return + (*>) = (>>) + +instance Monad M where + return = undefined + (>>=) = undefined + (>>) = undefined ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr ===================================== @@ -0,0 +1,45 @@ + +WarnNoncanonical.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘(<>) = mappend’ definition detected + in the instance declaration for ‘Semigroup S’. + Suggested fix: + Move definition from ‘mappend’ to ‘(<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘mappend’ definition detected + in the instance declaration for ‘Monoid S’. + ‘mappend’ will eventually be removed in favour of ‘(<>)’ + Suggested fix: + Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘pure = return’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘return’ to ‘pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(*>) = (>>)’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘(>>)’ to ‘(*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘return’ definition detected + in the instance declaration for ‘Monad M’. + ‘return’ will eventually be removed in favour of ‘pure’ + Suggested fix: + Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(>>)’ definition detected + in the instance declaration for ‘Monad M’. + ‘(>>)’ will eventually be removed in favour of ‘(*>)’ + Suggested fix: + Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -68,3 +68,4 @@ test('T22702b', normal, compile, ['']) test('T22826', normal, compile, ['']) test('T23573', [extra_files(["T23573.hs", "T23573A.hs", "T23573B.hs"])], multimod_compile, ['T23573', '-v0']) test('T23465', normal, compile, ['-ddump-parsed']) +test('WarnNoncanonical', normal, compile, ['']) ===================================== testsuite/tests/wcompat-warnings/Template.hs ===================================== @@ -1,30 +1,13 @@ +{-# LANGUAGE DataKinds #-} module WCompatWarningsOnOff where -import qualified Data.Semigroup as Semi +import Data.Proxy +import GHC.Types +import Data.List +import Data.Kind -(<>) = undefined -- Semigroup warnings +type T1 = 'Nothing :: Maybe a --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 - -newtype M a = M a - -instance Functor M where - fmap = undefined - -instance Applicative M where - liftA2 = undefined - pure = return - (*>) = (>>) - -instance Monad M where - return = undefined - (>>=) = undefined - (>>) = undefined +foo :: Maybe a -> Maybe a +foo (Just @b x) = Just @b x +foo _ = Nothing ===================================== testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr ===================================== @@ -1,45 +1,15 @@ -Template.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(<>) = mappend’ definition detected - in the instance declaration for ‘Semigroup S’. - Suggested fix: - Move definition from ‘mappend’ to ‘(<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘mappend’ definition detected - in the instance declaration for ‘Monoid S’. - ‘mappend’ will eventually be removed in favour of ‘(<>)’ - Suggested fix: - Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘pure = return’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘return’ to ‘pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(*>) = (>>)’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘(>>)’ to ‘(*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘return’ definition detected - in the instance declaration for ‘Monad M’. - ‘return’ will eventually be removed in favour of ‘pure’ - Suggested fix: - Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(>>)’ definition detected - in the instance declaration for ‘Monad M’. - ‘(>>)’ will eventually be removed in favour of ‘(*>)’ - Suggested fix: - Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return +Template.hs:6:8: warning: [GHC-82347] [-Wcompat-unqualified-imports (in -Wcompat)] + To ensure compatibility with future core libraries changes + imports to Data.List should be + either qualified or have an explicit import list. + +Template.hs:9:29: warning: [GHC-16382] [-Wimplicit-rhs-quantification (in -Wcompat)] + The variable ‘a’ occurs free on the RHS of the type declaration + In the future GHC will no longer implicitly quantify over such variables + Suggested fix: Bind ‘a’ on the LHS of the type declaration + +Template.hs:12:6: warning: [GHC-69797] [-Wdeprecated-type-abstractions (in -Wcompat)] + Type applications in constructor patterns will require + the TypeAbstractions extension starting from GHC 9.14. + Suggested fix: Perhaps you intended to use TypeAbstractions View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a7a1c027348723a91902cae65e70f3539b9e416 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a7a1c027348723a91902cae65e70f3539b9e416 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 Dec 18 18:16:01 2023 From: gitlab at gitlab.haskell.org (Krzysztof Gogolewski (@monoidal)) Date: Mon, 18 Dec 2023 13:16:01 -0500 Subject: [Git][ghc/ghc][wip/T24267] Turn -Wtype-equality-out-of-scope on by default Message-ID: <65808c612fdcb_e7a737336b7d04367aa@gitlab.mail> Krzysztof Gogolewski pushed to branch wip/T24267 at Glasgow Haskell Compiler / GHC Commits: b404e610 by Krzysztof Gogolewski at 2023-12-18T19:15:30+01:00 Turn -Wtype-equality-out-of-scope on by default Also remove -Wnoncanonical-{monoid,monad}-instances from -Wcompat, since they are enabled by default. Refresh wcompat-warnings/ test with new -Wcompat warnings. Part of #24267 - - - - - 10 changed files: - compiler/GHC/Driver/Flags.hs - docs/users_guide/using-warnings.rst - testsuite/tests/ghci/scripts/ghci024.stdout - testsuite/tests/warnings/should_compile/T18862b.hs - testsuite/tests/warnings/should_compile/T18862b.stderr - + testsuite/tests/warnings/should_compile/WarnNoncanonical.hs - + testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr - testsuite/tests/warnings/should_compile/all.T - testsuite/tests/wcompat-warnings/Template.hs - testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr Changes: ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -952,7 +952,8 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnBadlyStagedTypes, Opt_WarnTypeEqualityRequiresOperators, Opt_WarnInconsistentFlags, - Opt_WarnDataKindsTC + Opt_WarnDataKindsTC, + Opt_WarnTypeEqualityOutOfScope ] -- | Things you get with -W @@ -1002,10 +1003,7 @@ minusWeverythingOpts = [ toEnum 0 .. ] minusWcompatOpts :: [WarningFlag] minusWcompatOpts = [ Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnNonCanonicalMonadInstances , Opt_WarnCompatUnqualifiedImports - , Opt_WarnTypeEqualityOutOfScope , Opt_WarnImplicitRhsQuantification , Opt_WarnDeprecatedTypeAbstractions ] ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -78,8 +78,12 @@ as ``-Wno-...`` for every individual warning in the group. * :ghc-flag:`-Wforall-identifier` * :ghc-flag:`-Wgadt-mono-local-binds` * :ghc-flag:`-Wtype-equality-requires-operators` + * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wbadly-staged-types` * :ghc-flag:`-Winconsistent-flags` + * :ghc-flag:`-Wnoncanonical-monoid-instances` + * :ghc-flag:`-Wnoncanonical-monad-instances` + * :ghc-flag:`-Wdata-kinds-tc` .. ghc-flag:: -W :shortdesc: enable normal warnings @@ -166,10 +170,7 @@ as ``-Wno-...`` for every individual warning in the group. :columns: 3 * :ghc-flag:`-Wsemigroup` - * :ghc-flag:`-Wnoncanonical-monoid-instances` - * :ghc-flag:`-Wnoncanonical-monad-instances` * :ghc-flag:`-Wcompat-unqualified-imports` - * :ghc-flag:`-Wtype-equality-out-of-scope` * :ghc-flag:`-Wimplicit-rhs-quantification` * :ghc-flag:`-Wdeprecated-type-abstractions` @@ -591,8 +592,6 @@ of ``-W(no-)*``. * Warn if ``pure`` is defined backwards (i.e. ``pure = return``). * Warn if ``(*>)`` is defined backwards (i.e. ``(*>) = (>>)``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wnoncanonical-monadfail-instances :shortdesc: *(deprecated)* warn when ``Monad`` or ``MonadFail`` instances have @@ -636,8 +635,6 @@ of ``-W(no-)*``. * Warn if ``(<>)`` is defined backwards (i.e. ``(<>) = mappend``). - This warning is part of the :ghc-flag:`-Wcompat` option group. - .. ghc-flag:: -Wmissing-monadfail-instances :shortdesc: *(deprecated)* Warn when a failable pattern is used in a do-block that does @@ -2379,6 +2376,7 @@ of ``-W(no-)*``. :reverse: -Wno-type-equality-out-of-scope :since: 9.4.1 + :default: on In accordance with `GHC Proposal #371 `__, @@ -2395,9 +2393,6 @@ of ``-W(no-)*``. custom Prelude. In this case, consider updating your custom Prelude to re-export ``~`` from ``Data.Type.Equality``. - Being part of the :ghc-flag:`-Wcompat` option group, this warning is off by - default, but will be switched on in a future GHC release. - .. ghc-flag:: -Wtype-equality-requires-operators :shortdesc: warn when type equality ``a ~ b`` is used despite being out of scope :type: dynamic ===================================== testsuite/tests/ghci/scripts/ghci024.stdout ===================================== @@ -18,7 +18,6 @@ other dynamic, non-language, flag settings: warning settings: -Wsemigroup -Wcompat-unqualified-imports - -Wtype-equality-out-of-scope -Wimplicit-rhs-quantification -Wdeprecated-type-abstractions ~~~~~~~~~~ Testing :set -a ===================================== testsuite/tests/warnings/should_compile/T18862b.hs ===================================== @@ -1,4 +1,4 @@ -{-# OPTIONS -Wcompat -Wno-error=type-equality-out-of-scope #-} +{-# OPTIONS -Wno-error=type-equality-out-of-scope #-} module T18862b where ===================================== testsuite/tests/warnings/should_compile/T18862b.stderr ===================================== @@ -1,5 +1,5 @@ -T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wcompat)] +T18862b.hs:7:9: warning: [GHC-12003] [-Wtype-equality-out-of-scope (in -Wdefault)] • The ‘~’ operator is out of scope. Assuming it to stand for an equality constraint. • NB: ‘~’ used to be built-in syntax but now is a regular type operator ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.hs ===================================== @@ -0,0 +1,30 @@ +module WarnNoncanonical where + +import qualified Data.Semigroup as Semi + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 + +newtype M a = M a + +instance Functor M where + fmap = undefined + +instance Applicative M where + liftA2 = undefined + pure = return + (*>) = (>>) + +instance Monad M where + return = undefined + (>>=) = undefined + (>>) = undefined ===================================== testsuite/tests/warnings/should_compile/WarnNoncanonical.stderr ===================================== @@ -0,0 +1,45 @@ + +WarnNoncanonical.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘(<>) = mappend’ definition detected + in the instance declaration for ‘Semigroup S’. + Suggested fix: + Move definition from ‘mappend’ to ‘(<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault)] + Noncanonical ‘mappend’ definition detected + in the instance declaration for ‘Monoid S’. + ‘mappend’ will eventually be removed in favour of ‘(<>)’ + Suggested fix: + Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid + +WarnNoncanonical.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘pure = return’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘return’ to ‘pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(*>) = (>>)’ definition detected + in the instance declaration for ‘Applicative M’. + Suggested fix: + Move definition from ‘(>>)’ to ‘(*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘return’ definition detected + in the instance declaration for ‘Monad M’. + ‘return’ will eventually be removed in favour of ‘pure’ + Suggested fix: + Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return + +WarnNoncanonical.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault)] + Noncanonical ‘(>>)’ definition detected + in the instance declaration for ‘Monad M’. + ‘(>>)’ will eventually be removed in favour of ‘(*>)’ + Suggested fix: + Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ + See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return ===================================== testsuite/tests/warnings/should_compile/all.T ===================================== @@ -68,3 +68,4 @@ test('T22702b', normal, compile, ['']) test('T22826', normal, compile, ['']) test('T23573', [extra_files(["T23573.hs", "T23573A.hs", "T23573B.hs"])], multimod_compile, ['T23573', '-v0']) test('T23465', normal, compile, ['-ddump-parsed']) +test('WarnNoncanonical', normal, compile, ['']) ===================================== testsuite/tests/wcompat-warnings/Template.hs ===================================== @@ -1,30 +1,13 @@ +{-# LANGUAGE DataKinds #-} module WCompatWarningsOnOff where -import qualified Data.Semigroup as Semi +import Data.Proxy +import GHC.Types +import Data.List +import Data.Kind -(<>) = undefined -- Semigroup warnings +type T1 = 'Nothing :: Maybe a --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 - -newtype M a = M a - -instance Functor M where - fmap = undefined - -instance Applicative M where - liftA2 = undefined - pure = return - (*>) = (>>) - -instance Monad M where - return = undefined - (>>=) = undefined - (>>) = undefined +foo :: Maybe a -> Maybe a +foo (Just @b x) = Just @b x +foo _ = Nothing ===================================== testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr ===================================== @@ -1,45 +1,15 @@ -Template.hs:11:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(<>) = mappend’ definition detected - in the instance declaration for ‘Semigroup S’. - Suggested fix: - Move definition from ‘mappend’ to ‘(<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:14:3: warning: [GHC-50928] [-Wnoncanonical-monoid-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘mappend’ definition detected - in the instance declaration for ‘Monoid S’. - ‘mappend’ will eventually be removed in favour of ‘(<>)’ - Suggested fix: - Either remove definition for ‘mappend’ (recommended) or define as ‘mappend = (<>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid - -Template.hs:24:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘pure = return’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘return’ to ‘pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:25:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(*>) = (>>)’ definition detected - in the instance declaration for ‘Applicative M’. - Suggested fix: - Move definition from ‘(>>)’ to ‘(*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:28:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘return’ definition detected - in the instance declaration for ‘Monad M’. - ‘return’ will eventually be removed in favour of ‘pure’ - Suggested fix: - Either remove definition for ‘return’ (recommended) or define as ‘return = pure’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return - -Template.hs:30:3: warning: [GHC-22705] [-Wnoncanonical-monad-instances (in -Wdefault, -Wcompat)] - Noncanonical ‘(>>)’ definition detected - in the instance declaration for ‘Monad M’. - ‘(>>)’ will eventually be removed in favour of ‘(*>)’ - Suggested fix: - Either remove definition for ‘(>>)’ (recommended) or define as ‘(>>) = (*>)’ - See also: https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return +Template.hs:6:8: warning: [GHC-82347] [-Wcompat-unqualified-imports (in -Wcompat)] + To ensure compatibility with future core libraries changes + imports to Data.List should be + either qualified or have an explicit import list. + +Template.hs:9:29: warning: [GHC-16382] [-Wimplicit-rhs-quantification (in -Wcompat)] + The variable ‘a’ occurs free on the RHS of the type declaration + In the future GHC will no longer implicitly quantify over such variables + Suggested fix: Bind ‘a’ on the LHS of the type declaration + +Template.hs:12:6: warning: [GHC-69797] [-Wdeprecated-type-abstractions (in -Wcompat)] + Type applications in constructor patterns will require + the TypeAbstractions extension starting from GHC 9.14. + Suggested fix: Perhaps you intended to use TypeAbstractions View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b404e6108d449d54d1caf96b1b1c190da5d1f7a3 -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b404e6108d449d54d1caf96b1b1c190da5d1f7a3 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 Dec 18 19:11:48 2023 From: gitlab at gitlab.haskell.org (Apoorv Ingle (@ani)) Date: Mon, 18 Dec 2023 14:11:48 -0500 Subject: [Git][ghc/ghc][wip/expand-do] remove isGoodCoverateExpr. it is not needed Message-ID: <658099748dc63_e7a737445596044671@gitlab.mail> Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC Commits: 32997c7b by Apoorv Ingle at 2023-12-18T13:11:33-06:00 remove isGoodCoverateExpr. it is not needed - - - - - 5 changed files: - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Gen/Do.hs - testsuite/tests/hpc/function/tough.stdout - testsuite/tests/hpc/function2/tough2.stdout - testsuite/tests/hpc/simple/hpc001.stdout Changes: ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -304,7 +304,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs -- TODO: better name for rhs's for non-simple patterns? let name = maybe "(...)" getOccString simplePatId - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False PatBindRhs rhs let pat' = pat { pat_rhs = rhs'} -- Should create ticks here? @@ -375,7 +375,7 @@ addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage | isGoodCoverageExpr e0 -> tick_it + TickForCoverage -> tick_it TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where @@ -393,7 +393,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 +409,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,30 +440,12 @@ 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 +isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt stmt) _)) + | LastStmt{} <- unLoc stmt = True | otherwise - = isCallSite e -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 - +isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True @@ -476,15 +457,16 @@ isCallSite (XExpr (ExpandedThingTc _ e)) -- NB: OpApp, SectionL, SectionR are all expanded out isCallSite _ = False -addTickLHsExprOptAlt :: Bool -> Bool {- is do expansion -} +addTickLHsExprOptAlt :: Bool + -> HsMatchContext GhcTc -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany isExpansion e@(L pos e0) - = if not (isExpansion) - then ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False (locA pos) - $ addTickHsExpr e0) - (addTickLHsExpr e) - else (addTickLHsExprNever e) +addTickLHsExprOptAlt oneOfMany ctxt e@(L pos e0) + = ifDensity TickForCoverage + (case ctxt of + StmtCtxt{} -> addTickLHsExprNever e -- A lambda alternative generated due to do-expansion + _ -> allocTickBox (ExpBox oneOfMany) False False (locA pos) + $ addTickHsExpr e0) + (addTickLHsExpr e) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0) @@ -552,11 +534,11 @@ 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 IfAlt e2) + (addTickLHsExprOptAlt True IfAlt e3) addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts + ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False IfAlt) alts ; return $ HsMultiIf ty alts' } addTickHsExpr (HsLet x binds e) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ do @@ -650,40 +632,41 @@ 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 +addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_ctxt = ctxt + , m_pats = pats , m_grhss = gRHSs }) = bindLocals (collectPatsBinders CollNoDictBinders pats) $ do - gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs + gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp ctxt gRHSs return $ match { m_grhss = gRHSs' } -addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) +addTickGRHSs :: Bool -> Bool -> Bool -> HsMatchContext GhcTc -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) = +addTickGRHSs isOneOfMany isLambda isDoExp ctxt (GRHSs x guarded local_binds) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded + guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp ctxt)) guarded return $ GRHSs x guarded' local_binds' where binders = collectLocalBinders CollNoDictBinders local_binds -addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) +addTickGRHS :: Bool -> Bool -> Bool -> HsMatchContext GhcTc -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do +addTickGRHS isOneOfMany isLambda isDoExp ctxt (GRHS x stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda isDoExp expr) + (addTickGRHSBody isOneOfMany isLambda isDoExp ctxt expr) return $ GRHS x stmts' expr' -addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do +addTickGRHSBody :: Bool -> Bool -> Bool -> HsMatchContext GhcTc -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda isDoExp ctxt 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 + TickForCoverage -> addTickLHsExprOptAlt isOneOfMany ctxt expr TickAllFunctions | isLambda -> addPathEntry "\\" $ allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -210,7 +210,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/function/tough.stdout ===================================== @@ -11,7 +11,7 @@ CallStack (from HasCallStack): (1,2,3) - 71% expressions used (79/110) + 73% expressions used (74/101) 14% boolean coverage (1/7) 0% guards (0/4), 3 always True, 1 always False 33% 'if' conditions (1/3), 1 always True, 1 always False @@ -22,7 +22,7 @@ CallStack (from HasCallStack): ---------- - 71% expressions used (79/110) + 73% expressions used (74/101) 14% boolean coverage (1/7) 0% guards (0/4), 3 always True, 1 always False 33% 'if' conditions (1/3), 1 always True, 1 always False @@ -114,10 +114,10 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } - + - +
moduleTop Level DefinitionsAlternativesExpressions
%covered / total%covered / total%covered / total
  module Main83%5/6
58%7/12
71%79/110
83%5/6
58%7/12
73%74/101
  Program Coverage Total83%5/6
58%7/12
71%79/110
83%5/6
58%7/12
73%74/101
Writing: hpc_index_fun.html