[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: EPA: preserve comments in class and data decls

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sun May 5 20:56:06 UTC 2024



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


Commits:
35d34fde by Alan Zimmerman at 2024-05-05T12:52:40-04:00
EPA: preserve comments in class and data decls

Fix checkTyClHdr which was discarding comments.

Closes #24755

- - - - -
03c5dfbf by Simon Peyton Jones at 2024-05-05T12:53:15-04:00
Fix a float-out error

Ticket #24768 showed that the Simplifier was accidentally destroying
a join point.  It turned out to be that we were sending a bottoming
join point to the top, accidentally abstracting over /other/ join
points.

Easily fixed.

- - - - -
3371b3a1 by John Ericson at 2024-05-05T16:55:50-04:00
Substitute bindist files with Hadrian not configure

The `ghc-toolchain` overhaul will eventually replace all this stuff with
something much more cleaned up, but I think it is still worth making
this sort of cleanup in the meantime so other untanglings and dead code
cleaning can procede.

I was able to delete a fair amount of dead code doing this too.

`LLVMTarget_CPP` is renamed to / merged with `LLVMTarget` because it
wasn't actually turned into a valid CPP identifier. (Original to
1345c7cc42c45e63ab1726a8fd24a7e4d4222467, actually.)

Progress on #23966

Co-Authored-By: Sylvain Henry <hsyl20 at gmail.com>

- - - - -
0f74e544 by Alan Zimmerman at 2024-05-05T16:55:51-04:00
EPA: fix mkHsOpTyPV duplicating comments

Closes #24753

- - - - -


17 changed files:

- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Parser/PostProcess.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/bindist/Makefile
- hadrian/bindist/config.mk.in
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/BinaryDist.hs
- hadrian/src/Rules/Generate.hs
- mk/project.mk.in
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24753.hs
- + testsuite/tests/printer/Test24755.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/simplCore/should_compile/T24768.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1088,6 +1088,11 @@ But, as ever, we need to be careful:
     as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
     argument.
 
+    Do /not/ do this for bottoming /join-point/ bindings.   They may call other
+    join points (#24768), and floating to the top would abstract over those join
+    points, which we should never do.
+
+
 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
 of functional programs" (unpublished I think).
 
@@ -1252,9 +1257,11 @@ lvlBind env (AnnNonRec bndr rhs)
 
     deann_rhs  = deAnnotate rhs
     mb_bot_str = exprBotStrictness_maybe deann_rhs
-    is_bot_lam = isJust mb_bot_str
+    is_bot_lam = not is_join && isJust mb_bot_str
         -- is_bot_lam: looks like (\xy. bot), maybe zero lams
-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
+        -- NB: not isBottomThunk!
+        -- NB: not is_join: don't send bottoming join points to the top.
+        -- See Note [Bottoming floats] point (3)
 
     is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty
     n_extra       = count isId abs_vars


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -204,11 +204,11 @@ mkClassDecl :: SrcSpan
             -> P (LTyClDecl GhcPs)
 
 mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
-  = do { let loc = noAnnSrcSpan loc'
-       ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
-       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
+  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+       ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
        ; tyvars <- checkTyVars (text "class") whereDots cls tparams
        ; let anns' = annsIn Semi.<> ann
+       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
        ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
                                   , tcdCtxt = mcxt
                                   , tcdLName = cls, tcdTyVars = tyvars
@@ -231,12 +231,12 @@ mkTyData :: SrcSpan
          -> P (LTyClDecl GhcPs)
 mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
          ksig data_cons (L _ maybe_deriv) annsIn
-  = do { let loc = noAnnSrcSpan loc'
-       ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
        ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
        ; let anns' = annsIn Semi.<> ann
-       ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
+       ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
        ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
+       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
        ; return (L loc (DataDecl { tcdDExt = anns',
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
@@ -263,14 +263,14 @@ mkTySynonym :: SrcSpan
             -> [AddEpAnn]
             -> P (LTyClDecl GhcPs)
 mkTySynonym loc lhs rhs annsIn
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
        ; tyvars <- checkTyVars (text "type") equalsDots tc tparams
        ; let anns' = annsIn Semi.<> ann
-       ; return (L (noAnnSrcSpan loc) (SynDecl
-                                { tcdSExt = anns'
-                                , tcdLName = tc, tcdTyVars = tyvars
-                                , tcdFixity = fixity
-                                , tcdRhs = rhs })) }
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (SynDecl { tcdSExt = anns'
+                                 , tcdLName = tc, tcdTyVars = tyvars
+                                 , tcdFixity = fixity
+                                 , tcdRhs = rhs })) }
 
 mkStandaloneKindSig
   :: SrcSpan
@@ -303,8 +303,9 @@ mkTyFamInstEqn :: SrcSpan
                -> [AddEpAnn]
                -> P (LTyFamInstEqn GhcPs)
 mkTyFamInstEqn loc bndrs lhs rhs anns
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
-       ; return (L (noAnnSrcSpan loc) $ FamEqn
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' $ FamEqn
                         { feqn_ext    = anns `mappend` ann
                         , feqn_tycon  = tc
                         , feqn_bndrs  = bndrs
@@ -324,10 +325,11 @@ mkDataFamInst :: SrcSpan
               -> P (LInstDecl GhcPs)
 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
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
        ; 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
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
                   (FamEqn { feqn_ext    = ann Semi.<> anns
                           , feqn_tycon  = tc
                           , feqn_bndrs  = bndrs
@@ -368,10 +370,10 @@ mkFamDecl :: SrcSpan
           -> [AddEpAnn]
           -> P (LTyClDecl GhcPs)
 mkFamDecl loc info topLevel lhs ksig injAnn annsIn
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
        ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
-       ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
-                                         (FamilyDecl
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (FamDecl noExtField (FamilyDecl
                                            { fdExt       = annsIn Semi.<> ann
                                            , fdTopLevel  = topLevel
                                            , fdInfo      = info, fdLName = tc
@@ -1040,45 +1042,46 @@ checkTyClHdr :: Bool               -- True  <=> class header
              -> P (LocatedN RdrName,     -- the head symbol (type or class name)
                    [LHsTypeArg GhcPs],   -- parameters of head symbol
                    LexicalFixity,        -- the declaration is in infix format
-                   [AddEpAnn])           -- API Annotation for HsParTy
+                   [AddEpAnn],           -- API Annotation for HsParTy
                                          -- when stripping parens
+                   EpAnnComments)        -- Accumulated comments from re-arranging
 -- Well-formedness check and decomposition of type and class heads.
 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 --              Int :*: Bool   into    (:*:, [Int, Bool])
 -- returning the pieces
 checkTyClHdr is_cls ty
-  = goL ty [] [] [] Prefix
+  = goL emptyComments ty [] [] [] Prefix
   where
-    goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
+    goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix
 
     -- workaround to define '*' despite StarIsType
-    go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
+    go cs 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 ll l an
            ; return (L a' (Unqual name), acc, fix
-                    , (reverse ops') ++ cps') }
+                    , (reverse ops') ++ cps', cs) }
 
-    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, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+    go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+    go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
       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
+    go cs l (HsParTy _ ty)    acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
       where
         (o,c) = mkParensEpAnn (realSrcSpan (locA l))
-    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
+    go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
+    go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
+    go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
       = return (L (l2l l) (nameRdrName tup_name)
-               , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
+               , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
       where
         arity = length ts
         tup_name | is_cls    = cTupleTyConName arity
                  | otherwise = getName (tupleTyCon Boxed arity)
           -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
-    go l _ _ _ _ _
+    go _ l _ _ _ _ _
       = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
           (PsErrMalformedTyOrClDecl ty)
 
@@ -2056,7 +2059,10 @@ instance DisambTD (HsType GhcPs) where
   mkHsAppTyHeadPV = return
   mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)
   mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)
-  mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)
+  mkHsOpTyPV prom t1 op t2 = do
+    let (L l ty) = mkLHsOpTy prom t1 op t2
+    !cs <- getCommentsFor (locA l)
+    return (L (addCommentsToEpAnn l cs) ty)
   mkUnpackednessPV = addUnpackednessP
 
 dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
@@ -2098,8 +2104,9 @@ instance DisambTD DataConBuilder where
   mkHsOpTyPV prom lhs tc rhs = do
       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
       data_con <- eitherToP $ tyConToDataCon tc
+      !cs <- getCommentsFor (locA l)
       checkNotPromotedDataCon prom data_con
-      return $ L l (InfixDataConBuilder lhs data_con rhs)
+      return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)
     where
       l = combineLocsA lhs rhs
       check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)
@@ -3220,8 +3227,8 @@ mkSumOrTuplePat l Boxed a at Sum{} _ =
 
 mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
 mkLHsOpTy prom x op y =
-  let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
-  in L loc (mkHsOpTy prom x op y)
+  let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y
+  in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)
 
 mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
 mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr


=====================================
configure.ac
=====================================
@@ -379,15 +379,7 @@ then
 else
   TargetPlatformFull="${target_alias}"
 fi
-if test "$CrossCompiling" = "YES"
-then
-  # Use value passed by user from --target=
-  CrossCompilePrefix="${TargetPlatformFull}-"
-else
-  CrossCompilePrefix=""
-fi
 AC_SUBST(CrossCompiling)
-AC_SUBST(CrossCompilePrefix)
 AC_SUBST(TargetPlatformFull)
 
 dnl ** Which gcc to use?
@@ -623,9 +615,6 @@ FP_LD_NO_WARN_DUPLICATE_LIBRARIES([target], [CONF_GCC_LINKER_OPTS_STAGE2])
 FP_MERGE_OBJECTS_SUPPORTS_RESPONSE_FILES
 
 GHC_LLVM_TARGET_SET_VAR
-# we intend to pass trough --targets to llvm as is.
-LLVMTarget_CPP=`    echo "$LlvmTarget"`
-AC_SUBST(LLVMTarget_CPP)
 # The target is substituted into the distrib/configure.ac file
 AC_SUBST(LlvmTarget)
 
@@ -951,12 +940,10 @@ PREP_TARGET_FILE
 FIND_GHC_TOOLCHAIN([hadrian/cfg])
 
 AC_CONFIG_FILES(
-[ mk/project.mk
-  hadrian/cfg/system.config
+[ hadrian/cfg/system.config
   hadrian/ghci-cabal
   hadrian/ghci-multi-cabal
   hadrian/ghci-stack
-  distrib/configure.ac
   hadrian/cfg/default.host.target
   hadrian/cfg/default.target
 ])


=====================================
distrib/configure.ac.in
=====================================
@@ -23,19 +23,12 @@ bootstrap_llvm_target=@LlvmTarget@
 TargetHasLibm=@TargetHasLibm@
 AC_SUBST(TargetHasLibm)
 
-FFIIncludeDir=@FFIIncludeDir@
-FFILibDir=@FFILibDir@
-AC_SUBST(FFILibDir)
-AC_SUBST(FFIIncludeDir)
-
-LibdwIncludeDir=@LibdwIncludeDir@
-LibdwLibDir=@LibdwLibDir@
-AC_SUBST(LibdwLibDir)
-AC_SUBST(LibdwIncludeDir)
-
 UseLibffiForAdjustors=@UseLibffiForAdjustors@
 AC_SUBST(UseLibffiForAdjustors)
 
+GhcWithSMP=@GhcWithSMP@
+AC_SUBST(GhcWithSMP)
+
 # We have to run these unconditionally as FPTOOLS_SET_PLATFORMS_VARS wants the
 # values it computes.
 AC_CANONICAL_BUILD
@@ -59,13 +52,11 @@ if test "$target" != "$host" ; then
 fi
 LeadingUnderscore="@LeadingUnderscore@"
 CrossCompilePrefix="@CrossCompilePrefix@"
-TargetPlatformFull="${target}"
 TablesNextToCode="@TablesNextToCode@"
 
 AC_SUBST(LeadingUnderscore)
 AC_SUBST(CrossCompiling)
 AC_SUBST(CrossCompilePrefix)
-AC_SUBST(TargetPlatformFull)
 AC_SUBST(TablesNextToCode)
 
 Unregisterised="@Unregisterised@"


=====================================
hadrian/bindist/Makefile
=====================================
@@ -123,7 +123,7 @@ lib/settings : config.mk
 	@echo ',("target has subsections via symbols", "$(TargetHasSubsectionsViaSymbols)")' >> $@
 	@echo ',("target has libm", "$(TargetHasLibm)")' >> $@
 	@echo ',("Unregisterised", "$(GhcUnregisterised)")' >> $@
-	@echo ',("LLVM target", "$(LLVMTarget_CPP)")' >> $@
+	@echo ',("LLVM target", "$(LLVMTarget)")' >> $@
 	@echo ',("LLVM llc command", "$(SettingsLlcCommand)")' >> $@
 	@echo ',("LLVM opt command", "$(SettingsOptCommand)")' >> $@
 	@echo ',("LLVM llvm-as command", "$(SettingsLlvmAsCommand)")' >> $@


=====================================
hadrian/bindist/config.mk.in
=====================================
@@ -134,20 +134,9 @@ CrossCompiling        = @CrossCompiling@
 CrossCompilePrefix    = @CrossCompilePrefix@
 GhcUnregisterised     = @Unregisterised@
 
-# ArchSupportsSMP should be set iff there is support for that arch in
-# rts/include/stg/SMP.h
-ifeq "$(TargetArch_CPP)" "arm"
-# We don't support load/store barriers pre-ARMv7. See #10433.
-ArchSupportsSMP=$(if $(filter $(ARM_ISA),ARMv5 ARMv6),NO,YES)
-else ifeq "$(TargetArch_CPP)" "javascript"
-ArchSupportsSMP=NO
-else
-ArchSupportsSMP=$(strip $(patsubst $(TargetArch_CPP), YES, $(findstring $(TargetArch_CPP), i386 x86_64 sparc powerpc powerpc64 powerpc64le s390x aarch64 riscv64)))
-endif
-
 # The THREADED_RTS requires `BaseReg` to be in a register and the
 # `GhcUnregisterised` mode doesn't allow that.
-GhcWithSMP := $(strip $(if $(filter YESNO, $(ArchSupportsSMP)$(GhcUnregisterised)),YES,NO))
+GhcWithSMP := @GhcWithSMP@
 
 # Whether to include GHCi in the compiler.  Depends on whether the RTS linker
 # has support for this OS/ARCH combination.


=====================================
hadrian/cfg/system.config.in
=====================================
@@ -128,3 +128,5 @@ use-lib-dl        = @UseLibdl@
 use-lib-bfd       = @UseLibbfd@
 use-lib-pthread   = @UseLibpthread@
 need-libatomic    = @NeedLibatomic@
+
+emsdk-version     = @ConfiguredEmsdkVersion@


=====================================
hadrian/src/Oracles/Setting.hs
=====================================
@@ -72,6 +72,7 @@ data Setting = CursesIncludeDir
              | SystemGhc
              | TargetPlatformFull
              | BourneShell
+             | EmsdkVersion
 
 -- TODO compute solely in Hadrian, removing these variables' definitions
 -- from aclocal.m4 whenever they can be calculated from other variables
@@ -128,6 +129,7 @@ setting key = lookupSystemConfig $ case key of
     SystemGhc          -> "system-ghc"
     TargetPlatformFull -> "target-platform-full"
     BourneShell        -> "bourne-shell"
+    EmsdkVersion       -> "emsdk-version"
 
 -- | Look up the value of a 'SettingList' in @cfg/system.config@, tracking the
 -- result.


=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -337,6 +337,7 @@ bindistRules = do
     -- Prepare binary distribution configure script
     -- (generated under <ghc root>/distrib/configure by 'autoreconf')
     root -/- "bindist" -/- "ghc-*" -/- "configure" %> \configurePath -> do
+        need ["distrib" -/- "configure.ac"]
         ghcRoot <- topDirectory
         copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4")
         copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib")
@@ -360,8 +361,7 @@ bindistRules = do
     -- creating the archive).
     forM_ bindistInstallFiles $ \file ->
         root -/- "bindist" -/- "ghc-*" -/- file %> \dest -> do
-            ghcRoot <- topDirectory
-            copyFile (ghcRoot -/- fixup file) dest
+            copyFile (fixup file) dest
 
   where
     fixup f | f `elem` ["INSTALL", "README"] = "distrib" -/- f


=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -371,6 +371,57 @@ templateRules = do
     [ interpolateVar "LlvmMinVersion" $ replaceEq '.' ',' <$> setting LlvmMinVersion
     , interpolateVar "LlvmMaxVersion" $ replaceEq '.' ',' <$> setting LlvmMaxVersion
     ]
+  bindistRules
+
+bindistRules :: Rules ()
+bindistRules = do
+  templateRule ("mk" -/- "project.mk") $ mconcat
+    [ interpolateSetting "ProjectName" ProjectName
+    , interpolateSetting "ProjectVersion" ProjectVersion
+    , interpolateSetting "ProjectVersionInt" ProjectVersionInt
+    , interpolateSetting "ProjectPatchLevel" ProjectPatchLevel
+    , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1
+    , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2
+    , interpolateSetting "ProjectGitCommitId" ProjectGitCommitId
+
+    , interpolateVar "HostOS_CPP" $ fmap cppify $ interp $ queryHost queryOS
+
+    , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+    , interpolateVar "TargetPlatform_CPP" $ cppify <$> getTarget targetPlatformTriple
+    , interpolateVar "TargetArch_CPP" $ cppify <$> getTarget queryArch
+    , interpolateVar "TargetOS_CPP" $ cppify <$> getTarget queryOS
+    , interpolateVar "LLVMTarget" $ getTarget tgtLlvmTarget
+    ]
+  templateRule ("distrib" -/- "configure.ac") $ mconcat
+    [ interpolateSetting "ConfiguredEmsdkVersion" EmsdkVersion
+    , interpolateVar "CrossCompilePrefix" $ do
+        crossCompiling <- interp $ getFlag CrossCompiling
+        tpf <- setting TargetPlatformFull
+        pure $ if crossCompiling then tpf <> "-" else ""
+    , interpolateVar "LeadingUnderscore" $ yesNo <$> getTarget tgtSymbolsHaveLeadingUnderscore
+    , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion
+    , interpolateSetting "LlvmMinVersion" LlvmMinVersion
+    , interpolateVar "LlvmTarget" $ getTarget tgtLlvmTarget
+    , interpolateSetting "ProjectVersion" ProjectVersion
+    , interpolateVar "SettingsUseDistroMINGW" $ settingsFileSetting ToolchainSetting_DistroMinGW
+    , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode
+    , interpolateVar "TargetHasLibm" $ lookupSystemConfig "target-has-libm"
+    , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple
+    , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian
+    , interpolateVar "TargetWordSize" $ getTarget wordSize
+    , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised
+    , interpolateVar "UseLibdw" $ fmap yesNo $ interp $ getFlag UseLibdw
+    , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors
+    , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP
+    ]
+  where
+    interp = interpretInContext (semiEmptyTarget Stage2)
+    getTarget = interp . queryTarget
+
+-- | Given a 'String' replace characters '.' and '-' by underscores ('_') so that
+-- the resulting 'String' is a valid C preprocessor identifier.
+cppify :: String -> String
+cppify = replaceEq '-' '_' . replaceEq '.' '_'
 
 
 -- Generators
@@ -486,10 +537,11 @@ generateSettings settingsFile = do
     arSupportsAtFile' = yesNo . arSupportsAtFile . tgtAr
     arSupportsDashL' = yesNo . arSupportsDashL . tgtAr
     ranlibPath  = maybe "" (prgPath . ranlibProgram) . tgtRanlib
-    isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness
-    wordSize    = show . wordSize2Bytes . tgtWordSize
     mergeObjsSupportsResponseFiles' = maybe "NO" (yesNo . mergeObjsSupportsResponseFiles) . tgtMergeObjs
 
+isBigEndian, wordSize :: Toolchain.Target -> String
+isBigEndian = yesNo . (\case BigEndian -> True; LittleEndian -> False) . tgtEndianness
+wordSize    = show . wordSize2Bytes . tgtWordSize
 
 -- | Generate @Config.hs@ files.
 generateConfigHs :: Expr String


=====================================
mk/project.mk.in
=====================================
@@ -1,5 +1,5 @@
 # WARNING: mk/project.mk is automatically generated from mk/project.mk.in by
-# ./configure.  Make sure you are editing mk/project.mk.in, not mk/project.mk.
+# Hadrian.  Make sure you are editing mk/project.mk.in, not mk/project.mk.
 
 ################################################################################
 #
@@ -25,8 +25,7 @@
 # random .o-file stuff might change even if the .hi syntax doesn't
 
 ProjectName       = @ProjectName@
-ProjectTags       =
-ProjectVersion    = @ProjectVersion@$(ProjectTags)
+ProjectVersion    = @ProjectVersion@
 ProjectVersionInt = @ProjectVersionInt@
 ProjectPatchLevel = @ProjectPatchLevel@
 ProjectPatchLevel1 = @ProjectPatchLevel1@
@@ -81,41 +80,14 @@ ProjectGitCommitId = @ProjectGitCommitId@
 # You have to do a lot of work by hand to cross compile: see the
 # section on "Porting GHC" in the Building Guide.
 
-HOSTPLATFORM            = @HostPlatform@
 TARGETPLATFORM          = @TargetPlatform@
-BUILDPLATFORM           = @BuildPlatform@
 
-HostPlatform_CPP        = @HostPlatform_CPP@
-HostArch_CPP            = @HostArch_CPP@
 HostOS_CPP              = @HostOS_CPP@
-HostVendor_CPP          = @HostVendor_CPP@
 
 TargetPlatform_CPP      = @TargetPlatform_CPP@
 TargetArch_CPP          = @TargetArch_CPP@
 TargetOS_CPP            = @TargetOS_CPP@
-TargetVendor_CPP        = @TargetVendor_CPP@
-LLVMTarget_CPP          = @LLVMTarget_CPP@
-
-BuildPlatform_CPP       = @BuildPlatform_CPP@
-BuildArch_CPP           = @BuildArch_CPP@
-BuildOS_CPP             = @BuildOS_CPP@
-BuildVendor_CPP         = @BuildVendor_CPP@
-
- at HostPlatform_CPP@_HOST           = 1
- at TargetPlatform_CPP@_TARGET       = 1
- at BuildPlatform_CPP@_BUILD         = 1
-
- at HostArch_CPP@_HOST_ARCH          = 1
- at TargetArch_CPP@_TARGET_ARCH      = 1
- at BuildArch_CPP@_BUILD_ARCH        = 1
-
- at HostOS_CPP@_HOST_OS              = 1
- at TargetOS_CPP@_TARGET_OS          = 1
- at BuildOS_CPP@_BUILD_OS            = 1
-
- at HostVendor_CPP@_HOST_VENDOR      = 1
- at TargetVendor_CPP@_TARGET_VENDOR  = 1
- at BuildVendor_CPP@_BUILD_VENDOR    = 1
+LLVMTarget              = @LLVMTarget@
 
 ################################################################################
 #
@@ -123,13 +95,6 @@ BuildVendor_CPP         = @BuildVendor_CPP@
 #
 ################################################################################
 
-# Pin a suffix on executables? If so, what (Windows only).
-exeext0=@exeext_host@
-exeext1=@exeext_target@
-exeext2=@exeext_target@
-exeext3=@exeext_target@
-soext=@soext_target@
-
 # Windows_Host=YES if on a Windows platform
 ifneq "$(findstring $(HostOS_CPP), mingw32)" ""
 Windows_Host=YES
@@ -143,17 +108,3 @@ Darwin_Host=YES
 else
 Darwin_Host=NO
 endif
-
-# Windows_Target=YES if we are targeting a Windows platform
-ifneq "$(findstring $(TargetOS_CPP), mingw32)" ""
-Windows_Target=YES
-else
-Windows_Target=NO
-endif
-
-# Is the stage0 compiler affected by Bug #9439?
-GHC_LLVM_AFFECTED_BY_9439 = @GHC_LLVM_AFFECTED_BY_9439@
-
-ifeq "$(TargetArch_CPP)" "arm"
-ARM_ISA=@ARM_ISA@
-endif


=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -856,3 +856,13 @@ Test24749:
 Test24754:
 	$(CHECK_PPR)   $(LIBDIR) Test24754.hs
 	$(CHECK_EXACT) $(LIBDIR) Test24754.hs
+
+.PHONY: Test24755
+Test24755:
+	$(CHECK_PPR)   $(LIBDIR) Test24755.hs
+	$(CHECK_EXACT) $(LIBDIR) Test24755.hs
+
+.PHONY: Test24753
+Test24753:
+	$(CHECK_PPR)   $(LIBDIR) Test24753.hs
+	$(CHECK_EXACT) $(LIBDIR) Test24753.hs


=====================================
testsuite/tests/printer/Test24753.hs
=====================================
@@ -0,0 +1,8 @@
+module Test24753 where
+
+type ErrorChoiceApi
+     = "path0" :> Get '[JSON] Int                                     -- c0
+  :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- c4
+             :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- c5
+  :<|> "path5" :> (ReqBody '[JSON] Int      :> Post '[PlainText] Int  -- c6
+             :<|>  ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7


=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24755 where
+
+class
+    a -- Before operator
+    :+
+    b -- After operator


=====================================
testsuite/tests/printer/all.T
=====================================
@@ -204,3 +204,5 @@ test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
 test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
 test('Test24749', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24749'])
 test('Test24754', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24754'])
+test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
+test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])


=====================================
testsuite/tests/simplCore/should_compile/T24768.hs
=====================================
@@ -0,0 +1,56 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- In this example the simplifer destroyed a join point,
+-- namely the `loop` inside `detectLeaks`
+
+module T24768 (detectLeaks) where
+
+import Control.Monad (zipWithM_)
+import Control.Monad.Reader (ReaderT(..))
+import Control.Monad.State (StateT, evalStateT)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+data Debuggee
+
+newtype DebugM a = DebugM (ReaderT Debuggee IO a)
+                    deriving (Functor, Applicative, Monad)
+
+runSimple :: Debuggee -> DebugM a -> IO a
+runSimple d (DebugM a) = runReaderT a d
+
+cands :: [a]
+cands = []
+{-# NOINLINE cands #-}
+
+detectLeaks :: Debuggee -> IO ()
+detectLeaks e = loop M.empty
+  where
+    loop :: M.Map () RankInfo -> IO ()
+    loop rm = do
+      gs <- runSimple e $ mapM (findSlice rm) cands
+      zipWithM_ (\n _g -> writeFile
+                            ("slices/" ++ show @Int n ++ ".dot")
+                            "abcd")
+                [0..] gs
+      loop rm
+
+data RankInfo = RankInfo !Double !Int
+
+lookupRM :: () -> M.Map () RankInfo -> [((), RankInfo)]
+lookupRM k m = M.assocs filtered_map
+  where
+    (res_map, _) = M.partitionWithKey (\e _ -> e == k) m
+    filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map
+
+findSlice :: forall m a. Monad m => M.Map () RankInfo -> () -> m [a]
+findSlice rm _k = evalStateT go S.empty
+  where
+    go :: StateT s m [a]
+    go = do
+      let next_edges = lookupRM () rm
+      _ss <- concat <$> mapM (\_ -> go) next_edges
+      return []


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -515,3 +515,4 @@ test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
 test('T24370', normal, compile, ['-O'])
 test('T24551', normal, compile, ['-O -dcore-lint'])
 test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
+test('T24768', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a02a27cf93add1a80ec6404da928848bbae9fb4...0f74e54459ec7838c4f8954929b9f29fb35b73b3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5a02a27cf93add1a80ec6404da928848bbae9fb4...0f74e54459ec7838c4f8954929b9f29fb35b73b3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240505/04832efa/attachment-0001.html>


More information about the ghc-commits mailing list