[Git][ghc/ghc][wip/specialize-hdoc] 9 commits: Remove RTS hack for configuring

Krzysztof Gogolewski (@monoidal) gitlab at gitlab.haskell.org
Tue Jan 10 17:49:33 UTC 2023



Krzysztof Gogolewski pushed to branch wip/specialize-hdoc at Glasgow Haskell Compiler / GHC


Commits:
5d65773e by John Ericson at 2023-01-09T20:39:27-05:00
Remove RTS hack for configuring

See the brand new Note [Undefined symbols in the RTS] for additional
details.

- - - - -
e3fff751 by Sebastian Graf at 2023-01-09T20:40:02-05:00
Handle shadowing in DmdAnal (#22718)

Previously, when we had a shadowing situation like
```hs
f x = ... -- demand signature <1L><1L>

main = ... \f -> f 1 ...
```
we'd happily use the shadowed demand signature at the call site inside the
lambda. Of course, that's wrong and solution is simply to remove the demand
signature from the `AnalEnv` when we enter the lambda.
This patch does so for all binding constructs Core.

In #22718 the issue was caused by LetUp not shadowing away the existing demand
signature for the let binder in the let body. The resulting absent error is
fickle to reproduce; hence no reproduction test case. #17478 would help.

Fixes #22718.

It appears that TcPlugin_Rewrite regresses by ~40% on Darwin. It is likely that
DmdAnal was exploiting ill-scoped analysis results.

Metric increase ['bytes allocated'] (test_env=x86_64-darwin-validate):
    TcPlugin_Rewrite

- - - - -
d53f6f4d by Oleg Grenrus at 2023-01-09T21:11:02-05:00
Add safe list indexing operator: !?

With Joachim's amendments.

Implements https://github.com/haskell/core-libraries-committee/issues/110

- - - - -
cfaf1ad7 by Nicolas Trangez at 2023-01-09T21:11:03-05:00
rts, tests: limit thread name length to 15 bytes

On Linux, `pthread_setname_np` (or rather, the kernel) only allows for
thread names up to 16 bytes, including the terminating null byte.

This commit adds a note pointing this out in `createOSThread`, and fixes
up two instances where a thread name of more than 15 characters long was
used (in the RTS, and in a test-case).

Fixes: #22366
Fixes: https://gitlab.haskell.org/ghc/ghc/-/issues/22366
See: https://gitlab.haskell.org/ghc/ghc/-/issues/22366#note_460796

- - - - -
64286132 by Matthew Pickering at 2023-01-09T21:11:03-05:00
Store bootstrap_llvm_target and use it to set LlvmTarget in bindists

This mirrors some existing logic for the bootstrap_target which
influences how TargetPlatform is set.

As described on #21970 not storing this led to `LlvmTarget` being set incorrectly
and hence the wrong `--target` flag being passed to the C compiler.

Towards #21970

- - - - -
4724e8d1 by Matthew Pickering at 2023-01-09T21:11:04-05:00
Check for FP_LD_NO_FIXUP_CHAINS in installation configure script

Otherwise, when installing from a bindist the C flag isn't passed to the
C compiler.

This completes the fix for #22429

- - - - -
2e926b88 by Georgi Lyubenov at 2023-01-09T21:11:07-05:00
Fix outdated link to Happy section on sequences

- - - - -
146a1458 by Matthew Pickering at 2023-01-09T21:11:07-05:00
Revert "NCG(x86): Compile add+shift as lea if possible."

This reverts commit 20457d775885d6c3df020d204da9a7acfb3c2e5a.

See #22666 and #21777

- - - - -
0d68f927 by Krzysztof Gogolewski at 2023-01-10T18:49:15+01:00
Add 'docWithStyle' to improve codegen

This new combiator

docWithStyle :: IsOutput doc => doc -> (PprStyle -> SDoc) -> doc

let us remove the need for code to be polymorphic in HDoc
when not used in code style.

Metric Decrease:
    ManyConstructors
    T13035
    T1969

- - - - -


24 changed files:

- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Parser.y
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Name/Occurrence.hs
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Outputable.hs
- configure.ac
- distrib/configure.ac.in
- hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
- hadrian/src/Rules/Register.hs
- libraries/base/Data/List.hs
- libraries/base/Data/OldList.hs
- libraries/base/GHC/List.hs
- libraries/base/changelog.md
- m4/ghc_llvm_target.m4
- rts/posix/OSThreads.c
- rts/rts.cabal.in
- rts/sm/NonMoving.c
- − testsuite/tests/codeGen/should_gen_asm/AddMulX86.asm
- − testsuite/tests/codeGen/should_gen_asm/AddMulX86.hs
- testsuite/tests/codeGen/should_gen_asm/all.T
- testsuite/tests/rts/pause-resume/pause_resume.c


Changes:

=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -1048,29 +1048,10 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
 
     --------------------
     add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    -- x + imm
     add_code rep x (CmmLit (CmmInt y _))
         | is32BitInteger y
         , rep /= W8 -- LEA doesn't support byte size (#18614)
         = add_int rep x y
-    -- x + (y << imm)
-    add_code rep x y
-        -- Byte size is not supported and 16bit size is slow when computed via LEA
-        | rep /= W8 && rep /= W16
-        -- 2^3 = 8 is the highest multiplicator supported by LEA.
-        , Just (x,y,shift_bits) <- get_shift x y
-        = add_shiftL rep x y (fromIntegral shift_bits)
-        where
-          -- x + (y << imm)
-          get_shift x (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)])
-            | shift_bits <= 3
-            = Just (x, y, shift_bits)
-          -- (y << imm) + x
-          get_shift (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)]) x
-            | shift_bits <= 3
-            = Just (x, y, shift_bits)
-          get_shift _ _
-            = Nothing
     add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
       where format = intFormat rep
     -- TODO: There are other interesting patterns we want to replace
@@ -1085,7 +1066,6 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
     sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
 
     -- our three-operand add instruction:
-    add_int :: (Width -> CmmExpr -> Integer -> NatM Register)
     add_int width x y = do
         (x_reg, x_code) <- getSomeReg x
         let
@@ -1099,22 +1079,6 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
         --
         return (Any format code)
 
-    -- x + (y << shift_bits) using LEA
-    add_shiftL :: (Width -> CmmExpr -> CmmExpr -> Int -> NatM Register)
-    add_shiftL width x y shift_bits = do
-        (x_reg, x_code) <- getSomeReg x
-        (y_reg, y_code) <- getSomeReg y
-        let
-            format = intFormat width
-            imm = ImmInt 0
-            code dst
-               = (x_code `appOL` y_code) `snocOL`
-                 LEA format
-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg (2 ^ shift_bits)) imm))
-                        (OpReg dst)
-        --
-        return (Any format code)
-
     ----------------------
 
     -- See Note [DIV/IDIV for bytes]


=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -333,7 +333,8 @@ dmdAnalBindLetUp :: TopLevelFlag
                  -> WithDmdType (DmdResult CoreBind a)
 dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))
   where
-    WithDmdType body_ty body'   = anal_body env
+    WithDmdType body_ty body'   = anal_body (addInScopeAnalEnv env id)
+    -- See Note [Bringing a new variable into scope]
     WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id
     -- See Note [Finalising boxity for demand signatures]
 
@@ -473,7 +474,8 @@ dmdAnal' env dmd (App fun arg)
 dmdAnal' env dmd (Lam var body)
   | isTyVar var
   = let
-        WithDmdType body_ty body' = dmdAnal env dmd body
+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body
+        -- See Note [Bringing a new variable into scope]
     in
     WithDmdType body_ty (Lam var body')
 
@@ -481,7 +483,8 @@ dmdAnal' env dmd (Lam var body)
   = let (n, body_dmd)    = peelCallDmd dmd
           -- body_dmd: a demand to analyze the body
 
-        WithDmdType body_ty body' = dmdAnal env body_dmd body
+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body
+        -- See Note [Bringing a new variable into scope]
         WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var
         new_dmd_type = multDmdType n lam_ty
     in
@@ -493,7 +496,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
   -- can consider its field demands when analysing the scrutinee.
   | want_precise_field_dmds alt_con
   = let
-        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs
+        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+        -- See Note [Bringing a new variable into scope]
+        WithDmdType rhs_ty rhs'           = dmdAnal rhs_env dmd rhs
         WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs
         WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr
         !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd
@@ -629,7 +634,9 @@ dmdAnalSumAlts env dmd case_bndr (alt:alts)
 
 dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt
 dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
-  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs
+  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)
+    -- See Note [Bringing a new variable into scope]
+  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs
   , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
   , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
         -- See Note [Demand on case-alternative binders]
@@ -2399,7 +2406,7 @@ enterDFun bind env
 emptySigEnv :: SigEnv
 emptySigEnv = emptyVarEnv
 
--- | Extend an environment with the strictness IDs attached to the id
+-- | Extend an environment with the strictness sigs attached to the Ids
 extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
 extendAnalEnvs top_lvl env vars
   = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
@@ -2418,6 +2425,12 @@ extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
 lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
 lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
 
+addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }
+
+addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }
+
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }
 
@@ -2456,7 +2469,18 @@ findBndrDmd env dmd_ty id
 
     fam_envs = ae_fam_envs env
 
-{- Note [Making dictionary parameters strict]
+{- Note [Bringing a new variable into scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = blah
+   g = ...(\f. ...f...)...
+
+In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,
+not the top-level `f` (which will be in `ae_sigs`).  So it's very important
+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.
+Otherwise chaos results (#22718).
+
+Note [Making dictionary parameters strict]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?
 


=====================================
compiler/GHC/Parser.y
=====================================
@@ -540,8 +540,9 @@ importdecls
 This might seem like an awfully roundabout way to declare a list; plus, to add
 insult to injury you have to reverse the results at the end.  The answer is that
 left recursion prevents us from running out of stack space when parsing long
-sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for
-more guidance.
+sequences. See:
+https://haskell-happy.readthedocs.io/en/latest/using.html#parsing-sequences
+for more guidance.
 
 By adding/removing branches, you can affect what lists are accepted.  Here
 are the most common patterns, rewritten as regular expressions for clarity:


=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -265,10 +265,8 @@ instance Outputable CostCentre where
   ppr = pprCostCentre
 
 pprCostCentre :: IsLine doc => CostCentre -> doc
-pprCostCentre cc = docWithContext $ \ sty ->
-  if codeStyle (sdocStyle sty)
-  then ppCostCentreLbl cc
-  else ftext (costCentreUserNameFS cc)
+pprCostCentre cc = docWithStyle (ppCostCentreLbl cc)
+                                (\_ -> ftext (costCentreUserNameFS cc))
 {-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-}
 {-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 


=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -627,21 +627,30 @@ instance OutputableBndr Name where
 
 pprName :: forall doc. IsLine doc => Name -> doc
 pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
-  = docWithContext $ \ctx ->
-    let sty = sdocStyle ctx
-        debug = sdocPprDebug ctx
-        listTuplePuns = sdocListTuplePuns ctx
-    in handlePuns listTuplePuns (namePun_maybe name) $
-    case sort of
-      WiredIn mod _ builtin   -> pprExternal debug sty uniq mod occ True  builtin
-      External mod            -> pprExternal debug sty uniq mod occ False UserSyntax
-      System                  -> pprSystem   debug sty uniq occ
-      Internal                -> pprInternal debug sty uniq occ
+  = docWithStyle codeDoc normalDoc
   where
-    -- Print GHC.Types.List as [], etc.
-    handlePuns :: Bool -> Maybe FastString -> doc -> doc
-    handlePuns True (Just pun) _ = ftext pun
-    handlePuns _    _          r = r
+   codeDoc = case sort of
+               WiredIn mod _ _ -> pprModule mod <> char '_' <> ppr_z_occ_name occ
+               External mod    -> pprModule mod <> char '_' <> ppr_z_occ_name occ
+                                  -- In code style, always qualify
+                                  -- ToDo: maybe we could print all wired-in things unqualified
+                                  --       in code style, to reduce symbol table bloat?
+               System          -> pprUniqueAlways uniq
+               Internal        -> pprUniqueAlways uniq
+
+   normalDoc sty =
+     getPprDebug $ \debug ->
+     sdocOption sdocListTuplePuns $ \listTuplePuns ->
+       handlePuns listTuplePuns (namePun_maybe name) $
+       case sort of
+         WiredIn mod _ builtin   -> pprExternal debug sty uniq mod occ True  builtin
+         External mod            -> pprExternal debug sty uniq mod occ False UserSyntax
+         System                  -> pprSystem   debug sty uniq occ
+         Internal                -> pprInternal debug sty uniq occ
+
+   handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc
+   handlePuns True (Just pun) _ = ftext pun
+   handlePuns _    _          r = r
 {-# SPECIALISE pprName :: Name -> SDoc #-}
 {-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
@@ -674,12 +683,8 @@ pprTickyName this_mod name
 pprNameUnqualified :: Name -> SDoc
 pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ
 
-pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc
+pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc
 pprExternal debug sty uniq mod occ is_wired is_builtin
-  | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ
-        -- In code style, always qualify
-        -- ToDo: maybe we could print all wired-in things unqualified
-        --       in code style, to reduce symbol table bloat?
   | debug         = pp_mod <> ppr_occ_name occ
                      <> braces (hsep [if is_wired then text "(w)" else empty,
                                       pprNameSpaceBrief (occNameSpace occ),
@@ -695,9 +700,8 @@ pprExternal debug sty uniq mod occ is_wired is_builtin
     pp_mod = ppUnlessOption sdocSuppressModulePrefixes
                (pprModule mod <> dot)
 
-pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
+pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc
 pprInternal debug sty uniq occ
-  | codeStyle sty  = pprUniqueAlways uniq
   | debug          = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ),
                                                        pprUnique uniq])
   | dumpStyle sty  = ppr_occ_name occ <> ppr_underscore_unique uniq
@@ -706,9 +710,8 @@ pprInternal debug sty uniq occ
   | otherwise      = ppr_occ_name occ   -- User style
 
 -- Like Internal, except that we only omit the unique in Iface style
-pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc
-pprSystem debug sty uniq occ
-  | codeStyle sty  = pprUniqueAlways uniq
+pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc
+pprSystem debug _sty uniq occ
   | debug          = ppr_occ_name occ <> ppr_underscore_unique uniq
                      <> braces (pprNameSpaceBrief (occNameSpace occ))
   | otherwise      = ppr_occ_name occ <> ppr_underscore_unique uniq
@@ -717,7 +720,7 @@ pprSystem debug sty uniq occ
                                 -- so print the unique
 
 
-pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc
+pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
 -- Print the "M." part of a name, based on whether it's in scope or not
 -- See Note [Printing original names] in GHC.Types.Name.Ppr
 pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
@@ -728,20 +731,20 @@ pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
                           <> pprModuleName (moduleName mod) <> dot    -- scope either
       NameUnqual       -> empty                   -- In scope unqualified
 
-pprUnique :: IsLine doc => Unique -> doc
+pprUnique :: Unique -> SDoc
 -- Print a unique unless we are suppressing them
 pprUnique uniq
   = ppUnlessOption sdocSuppressUniques $
       pprUniqueAlways uniq
 
-ppr_underscore_unique :: IsLine doc => Unique -> doc
+ppr_underscore_unique :: Unique -> SDoc
 -- Print an underscore separating the name from its unique
 -- But suppress it if we aren't printing the uniques anyway
 ppr_underscore_unique uniq
   = ppUnlessOption sdocSuppressUniques $
       char '_' <> pprUniqueAlways uniq
 
-ppr_occ_name :: IsLine doc => OccName -> doc
+ppr_occ_name :: OccName -> SDoc
 ppr_occ_name occ = ftext (occNameFS occ)
         -- Don't use pprOccName; instead, just print the string of the OccName;
         -- we print the namespace in the debug stuff above


=====================================
compiler/GHC/Types/Name/Occurrence.hs
=====================================
@@ -200,7 +200,7 @@ pprNonVarNameSpace :: NameSpace -> SDoc
 pprNonVarNameSpace VarName = empty
 pprNonVarNameSpace ns = pprNameSpace ns
 
-pprNameSpaceBrief :: IsLine doc => NameSpace -> doc
+pprNameSpaceBrief :: NameSpace -> SDoc
 pprNameSpaceBrief DataName  = char 'd'
 pprNameSpaceBrief VarName   = char 'v'
 pprNameSpaceBrief TvName    = text "tv"
@@ -278,10 +278,9 @@ instance OutputableBndr OccName where
 
 pprOccName :: IsLine doc => OccName -> doc
 pprOccName (OccName sp occ)
-  = docWithContext $ \ sty ->
-    if codeStyle (sdocStyle sty)
-    then ztext (zEncodeFS occ)
-    else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))
+  = docWithStyle (ztext (zEncodeFS occ)) (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)))
+{-# SPECIALIZE pprOccName :: OccName -> SDoc #-}
+{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 {-
 ************************************************************************


=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -166,7 +166,7 @@ instance Outputable InstantiatedModule where
 instance Outputable InstantiatedUnit where
   ppr = pprInstantiatedUnit
 
-pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc
+pprInstantiatedUnit :: InstantiatedUnit -> SDoc
 pprInstantiatedUnit uid =
       -- getPprStyle $ \sty ->
       pprUnitId cid <>
@@ -180,8 +180,6 @@ pprInstantiatedUnit uid =
      where
       cid   = instUnitInstanceOf uid
       insts = instUnitInsts uid
-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-}
-{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit)
 --
@@ -203,14 +201,13 @@ instance IsUnitId u => IsUnitId (GenUnit u) where
    unitFS HoleUnit                = holeFS
 
 pprModule :: IsLine doc => Module -> doc
-pprModule mod@(Module p n) = docWithContext (doc . sdocStyle)
+pprModule mod@(Module p n) = docWithStyle code doc
  where
-  doc sty
-    | codeStyle sty =
-        (if p == mainUnit
+  code = (if p == mainUnit
                 then empty -- never qualify the main package in code
                 else ztext (zEncodeFS (unitFS p)) <> char '_')
             <> pprModuleName n
+  doc sty
     | qualModule sty mod =
         case p of
           HoleUnit -> angleBrackets (pprModuleName n)
@@ -352,12 +349,10 @@ stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2
 instance Outputable Unit where
    ppr pk = pprUnit pk
 
-pprUnit :: IsLine doc => Unit -> doc
+pprUnit :: Unit -> SDoc
 pprUnit (RealUnit (Definite d)) = pprUnitId d
 pprUnit (VirtUnit uid) = pprInstantiatedUnit uid
 pprUnit HoleUnit       = ftext holeFS
-{-# SPECIALIZE pprUnit :: Unit -> SDoc #-}
-{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
 
 instance Show Unit where
     show = unitString
@@ -535,12 +530,8 @@ instance Uniquable UnitId where
 instance Outputable UnitId where
     ppr = pprUnitId
 
-pprUnitId :: IsLine doc => UnitId -> doc
-pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs)
-                        -- see Note [Pretty-printing UnitId] in GHC.Unit
-                        -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-}
-{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+pprUnitId :: UnitId -> SDoc
+pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs)
 
 -- | A 'DefUnitId' is an 'UnitId' with the invariant that
 -- it only refers to a definite library; i.e., one we have generated


=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -126,6 +126,8 @@ import GHC.Data.FastString
 import qualified GHC.Utils.Ppr as Pretty
 import qualified GHC.Utils.Ppr.Colour as Col
 import GHC.Utils.Ppr       ( Doc, Mode(..) )
+import GHC.Utils.Panic.Plain (assert)
+import GHC.Utils.Constants (debugIsOn)
 import GHC.Serialized
 import GHC.LanguageExtensions (Extension)
 import GHC.Utils.GlobalVars( unsafeHasPprDebug )
@@ -855,9 +857,10 @@ ppWhenOption f doc = sdocOption f $ \case
    False -> empty
 
 {-# INLINE CONLIKE ppUnlessOption #-}
-ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc
-ppUnlessOption f doc = docWithContext $
-                          \ctx -> if f ctx then empty else doc
+ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
+ppUnlessOption f doc = sdocOption f $ \case
+   True  -> empty
+   False -> doc
 
 -- | Apply the given colour\/style for the argument.
 --
@@ -1040,10 +1043,7 @@ instance Outputable ModuleName where
 
 pprModuleName :: IsLine doc => ModuleName -> doc
 pprModuleName (ModuleName nm) =
-    docWithContext $ \ctx ->
-    if codeStyle (sdocStyle ctx)
-        then ztext (zEncodeFS nm)
-        else ftext nm
+    docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm)
 {-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-}
 {-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc]
 
@@ -1633,6 +1633,7 @@ IsOutput, that allows these combinators to be generic over both variants:
     class IsOutput doc where
       empty :: doc
       docWithContext :: (SDocContext -> doc) -> doc
+      docWithStyle :: doc -> (PprStyle -> SDoc) -> doc
 
     class IsOutput doc => IsLine doc
     class (IsOutput doc, IsLine (Line doc)) => IsDoc doc
@@ -1669,13 +1670,22 @@ arguments depending on the type they are instantiated at. They serve as a
 difficult to make completely equivalent under both printer implementations.
 
 These operations should generally be avoided, as they can result in surprising
-changes in behavior when the printer implementation is changed. However, in
-certain cases, the alternative is even worse. For example, we use dualLine in
-the implementation of pprUnitId, as the hack we use for printing unit ids
-(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine
-and is not necessary for code paths that use it, anyway.
-
-Use these operations wisely. -}
+changes in behavior when the printer implementation is changed.
+Right now, they are used only when outputting debugging comments in
+codegen, as it is difficult to adapt that code to use HLine and not necessary.
+
+Use these operations wisely.
+
+Note [docWithStyle]
+~~~~~~~~~~~~~~~~~~~
+Sometimes when printing, we consult the printing style. This can be done
+with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)',
+but:
+* For code style, 'docWithStyle c f' will return 'c'.
+* For other styles, 'docWithStyle c f', will call 'f style', but expect
+  an SDoc rather than doc. This removes the need to write code polymorphic
+  in SDoc and HDoc, since the latter is used only for code style.
+-}
 
 -- | Represents a single line of output that can be efficiently printed directly
 -- to a 'System.IO.Handle' (actually a 'BufHandle').
@@ -1700,7 +1710,7 @@ pattern HDoc f <- HDoc' f
 {-# COMPLETE HDoc #-}
 
 bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO ()
-bPutHDoc h ctx (HDoc f) = f ctx h
+bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h)
 
 -- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty',
 -- as well as access to the shared 'SDocContext'.
@@ -1709,6 +1719,7 @@ bPutHDoc h ctx (HDoc f) = f ctx h
 class IsOutput doc where
   empty :: doc
   docWithContext :: (SDocContext -> doc) -> doc
+  docWithStyle :: doc -> (PprStyle -> SDoc) -> doc  -- see Note [docWithStyle]
 
 -- | A class of types that represent a single logical line of text, with support
 -- for horizontal composition.
@@ -1779,6 +1790,11 @@ instance IsOutput SDoc where
   {-# INLINE CONLIKE empty #-}
   docWithContext = sdocWithContext
   {-# INLINE docWithContext #-}
+  docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx
+                                              in if codeStyle sty then c
+                                                                  else f sty)
+                     -- see Note [docWithStyle]
+  {-# INLINE CONLIKE docWithStyle #-}
 
 instance IsLine SDoc where
   char c = docToSDoc $ Pretty.char c
@@ -1823,12 +1839,18 @@ instance IsOutput HLine where
   {-# INLINE empty #-}
   docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h
   {-# INLINE CONLIKE docWithContext #-}
+  docWithStyle c@(HLine c') _ | debugIsOn = HLine $ \ctx h -> assert (codeStyle (sdocStyle ctx)) (c' ctx h)
+                              | otherwise = c   -- see Note [docWithStyle]
+  {-# INLINE CONLIKE docWithStyle #-}
 
 instance IsOutput HDoc where
   empty = HDoc (\_ _ -> pure ())
   {-# INLINE empty #-}
   docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h
   {-# INLINE CONLIKE docWithContext #-}
+  docWithStyle c@(HDoc c') _ | debugIsOn = HDoc $ \ctx h -> assert (codeStyle (sdocStyle ctx)) (c' ctx h)
+                             | otherwise = c   -- see Note [docWithStyle]
+  {-# INLINE CONLIKE docWithStyle #-}
 
 instance IsLine HLine where
   char c = HLine (\_ h -> bPutChar h c)


=====================================
configure.ac
=====================================
@@ -667,6 +667,8 @@ 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)
 
 dnl ** See whether cc supports --target=<triple> and set
 dnl CONF_CC_OPTS_STAGE[012] accordingly.


=====================================
distrib/configure.ac.in
=====================================
@@ -18,6 +18,8 @@ dnl--------------------------------------------------------------------
 dnl Various things from the source distribution configure
 bootstrap_target=@TargetPlatform@
 
+bootstrap_llvm_target=@LlvmTarget@
+
 TargetHasRTSLinker=@TargetHasRTSLinker@
 AC_SUBST(TargetHasRTSLinker)
 
@@ -169,6 +171,11 @@ 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])
 
+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])
+
 AC_SUBST(CONF_CC_OPTS_STAGE0)
 AC_SUBST(CONF_CC_OPTS_STAGE1)
 AC_SUBST(CONF_CC_OPTS_STAGE2)


=====================================
hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
=====================================
@@ -148,6 +148,8 @@ configurePackage context at Context {..} = do
     -- Figure out what hooks we need.
     hooks <- case C.buildType (C.flattenPackageDescription gpd) of
         C.Configure -> pure C.autoconfUserHooks
+        C.Simple -> pure C.simpleUserHooks
+        C.Make -> fail "build-type: Make is not supported"
         -- The 'time' package has a 'C.Custom' Setup.hs, but it's actually
         -- 'C.Configure' plus a @./Setup test@ hook. However, Cabal is also
         -- 'C.Custom', but doesn't have a configure script.
@@ -155,12 +157,6 @@ configurePackage context at Context {..} = do
             configureExists <- doesFileExist $
                 replaceFileName (pkgCabalFile package) "configure"
             pure $ if configureExists then C.autoconfUserHooks else C.simpleUserHooks
-        -- Not quite right, but good enough for us:
-        _ | package == rts ->
-            -- Don't try to do post configuration validation for 'rts'. This
-            -- will simply not work, due to the @ld-options@ and @Stg.h at .
-            pure $ C.simpleUserHooks { C.postConf = \_ _ _ _ -> return () }
-          | otherwise -> pure C.simpleUserHooks
 
     -- Compute the list of flags, and the Cabal configuration arguments
     flavourArgs <- args <$> flavour


=====================================
hadrian/src/Rules/Register.hs
=====================================
@@ -45,6 +45,14 @@ configurePackageRules = do
           isGmp <- (== "gmp") <$> interpretInContext ctx getBignumBackend
           when isGmp $
             need [buildP -/- "include/ghc-gmp.h"]
+        when (pkg == rts) $ do
+          -- Rts.h is a header listed in the cabal file, and configuring
+          -- therefore wants to ensure that the header "works" post-configure.
+          -- But it (transitively) includes these, so we must ensure they exist
+          -- for that check to work.
+          need [ buildP -/- "include/ghcautoconf.h"
+               , buildP -/- "include/ghcplatform.h"
+               ]
         Cabal.configurePackage ctx
 
     root -/- "**/autogen/cabal_macros.h" %> \out -> do


=====================================
libraries/base/Data/List.hs
=====================================
@@ -127,6 +127,7 @@ module Data.List
    -- | These functions treat a list @xs@ as a indexed collection,
    -- with indices ranging from 0 to @'length' xs - 1 at .
 
+   , (!?)
    , (!!)
 
    , elemIndex


=====================================
libraries/base/Data/OldList.hs
=====================================
@@ -127,6 +127,7 @@ module Data.OldList
    -- | These functions treat a list @xs@ as a indexed collection,
    -- with indices ranging from 0 to @'length' xs - 1 at .
 
+   , (!?)
    , (!!)
 
    , elemIndex


=====================================
libraries/base/GHC/List.hs
=====================================
@@ -31,7 +31,7 @@ module GHC.List (
    -- Other functions
    foldl1', concat, concatMap,
    map, (++), filter, lookup,
-   head, last, tail, init, uncons, (!!),
+   head, last, tail, init, uncons, (!?), (!!),
    scanl, scanl1, scanl', scanr, scanr1,
    iterate, iterate', repeat, replicate, cycle,
    take, drop, splitAt, takeWhile, dropWhile, span, break, reverse,
@@ -49,7 +49,7 @@ import GHC.Num (Num(..))
 import GHC.Num.Integer (Integer)
 import GHC.Stack.Types (HasCallStack)
 
-infixl 9  !!
+infixl 9  !?, !!
 infix  4 `elem`, `notElem`
 
 -- $setup
@@ -1370,9 +1370,10 @@ concat = foldr (++) []
 -- >>> ['a', 'b', 'c'] !! (-1)
 -- *** Exception: Prelude.!!: negative index
 --
--- WARNING: This function is partial. You can use
--- <https://hackage.haskell.org/package/safe/docs/Safe.html#v:atMay atMay>
--- instead.
+-- WARNING: This function is partial, and should only be used if you are
+-- sure that the indexing will not fail. Otherwise, use 'Data.List.!?'.
+--
+-- WARNING: This function takes linear time in the index.
 #if defined(USE_REPORT_PRELUDE)
 (!!)                    :: [a] -> Int -> a
 xs     !! n | n < 0 =  errorWithoutStackTrace "Prelude.!!: negative index"
@@ -1401,6 +1402,30 @@ xs !! n
                                    _ -> r (k-1)) tooLarge xs n
 #endif
 
+-- | List index (subscript) operator, starting from 0. Returns 'Nothing'
+-- if the index is out of bounds
+--
+-- >>> ['a', 'b', 'c'] !? 0
+-- Just 'a'
+-- >>> ['a', 'b', 'c'] !? 2
+-- Just 'c'
+-- >>> ['a', 'b', 'c'] !? 3
+-- Nothing
+-- >>> ['a', 'b', 'c'] !? (-1)
+-- Nothing
+--
+-- This is the total variant of the partial '!!' operator.
+--
+-- WARNING: This function takes linear time in the index.
+(!?) :: [a] -> Int -> Maybe a
+
+{-# INLINABLE (!?) #-}
+xs !? n
+  | n < 0     = Nothing
+  | otherwise = foldr (\x r k -> case k of
+                                   0 -> Just x
+                                   _ -> r (k-1)) (const Nothing) xs n
+
 --------------------------------------------------------------
 -- The zip family
 --------------------------------------------------------------


=====================================
libraries/base/changelog.md
=====================================
@@ -58,6 +58,8 @@
     freeing a `Pool`. (#14762) (#18338)
   * `Type.Reflection.Unsafe` is now marked as unsafe.
   * Add `Data.Typeable.heqT`, a kind-heterogeneous version of `Data.Typeable.eqT`.
+  * Add `Data.List.!?` per
+    [CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110).
 
 ## 4.17.0.0 *August 2022*
 


=====================================
m4/ghc_llvm_target.m4
=====================================
@@ -50,5 +50,10 @@ AC_DEFUN([GHC_LLVM_TARGET], [
 # require it.
 AC_DEFUN([GHC_LLVM_TARGET_SET_VAR], [
   AC_REQUIRE([FPTOOLS_SET_PLATFORMS_VARS])
-  GHC_LLVM_TARGET([$target],[$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
+  if test "$bootstrap_llvm_target" != ""
+  then
+    LlvmTarget=$bootstrap_llvm_target
+  else
+    GHC_LLVM_TARGET([$target],[$target_cpu],[$target_vendor],[$target_os],[LlvmTarget])
+  fi
 ])


=====================================
rts/posix/OSThreads.c
=====================================
@@ -218,6 +218,12 @@ start_thread (void *param)
     return startProc(startParam);
 }
 
+/* Note: at least on Linux/Glibc, `pthread_setname_np` restricts the name of
+ * a thread to 16 bytes, including the terminating null byte. Hence, make sure
+ * to only pass in names of up to 15 characters. Otherwise,
+ * `pthread_setname_np` when called in `start_thread` will fail with `ERANGE`,
+ * which is not checked for, and the thread won't be named at all.
+ */
 int
 createOSThread (OSThreadId* pId, const char *name,
                 OSThreadProc *startProc, void *param)


=====================================
rts/rts.cabal.in
=====================================
@@ -275,6 +275,8 @@ library
                         stg/SMP.h
                         stg/Ticky.h
                         stg/Types.h
+
+      -- See Note [Undefined symbols in the RTS]
       if flag(64bit)
         if flag(leading-underscore)
           ld-options:
@@ -474,6 +476,8 @@ library
         ld-options: "-Wl,-search_paths_first"
                     -- See Note [fd_set_overflow]
                     "-Wl,-U,___darwin_check_fd_set_overflow"
+                    -- See Note [Undefined symbols in the RTS]
+                    "-Wl,-undefined,dynamic_lookup"
         if !arch(x86_64) && !arch(aarch64)
            ld-options: -read_only_relocs warning
 
@@ -714,3 +718,35 @@ library
 --     , https://github.com/sitsofe/fio/commit/b6a1e63a1ff607692a3caf3c2db2c3d575ba2320
 
 -- The issue was originally reported in #19950
+
+
+-- Note [Undefined symbols in the RTS]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The RTS is built with a number of `-u` flags. This is to handle cyclic
+-- dependencies between the RTS and other libraries which we normally think of as
+-- downstream from the RTS. "Regular" dependencies from usages in those libraries
+-- to definitions in the RTS are handled normally. "Reverse" dependencies from
+-- usages in the RTS to definitions in those libraries get the `-u` flag in the
+-- RTS.
+--
+-- The symbols are specified literally, but follow C ABI conventions (as all 3 of
+-- C, C--, and Haskell do currently). Thus, we have to be careful to include a
+-- leading underscore or not based on those conventions for the given platform in
+-- question.
+--
+-- A tricky part is that different linkers have different policies regarding
+-- undefined symbols (not defined in the current binary, or found in a shared
+-- library that could be loaded at run time). GNU Binutils' linker is fine with
+-- undefined symbols by default, but Apple's "cctools" linker is not. To appease
+-- that linker we either need to do a blanket `-undefined dynamic_lookup` or
+-- whitelist each such symbol with an additional `-U` (see the man page for more
+-- details).
+--
+-- GHC already does `-undefined dynamic_lookup`, so we just do that for now, but
+-- we might try to get more precise with `-U` in the future.
+--
+-- Note that the RTS also `-u`s some atomics symbols that *are* defined --- and
+-- defined within the RTS! It is not immediately clear why this is needed. This
+-- dates back to c06e3f46d24ef69f3a3d794f5f604cb8c2a40cbc which mentions a build
+-- failure that it was suggested that this fix, but the precise reasoning is not
+-- explained.


=====================================
rts/sm/NonMoving.c
=====================================
@@ -1015,7 +1015,7 @@ void nonmovingCollect(StgWeak **dead_weaks, StgTSO **resurrected_threads)
         nonmoving_write_barrier_enabled = true;
         debugTrace(DEBUG_nonmoving_gc, "Starting concurrent mark thread");
         OSThreadId thread;
-        if (createOSThread(&thread, "non-moving mark thread",
+        if (createOSThread(&thread, "nonmoving-mark",
                            nonmovingConcurrentMark, mark_queue) != 0) {
             barf("nonmovingCollect: failed to spawn mark thread: %s", strerror(errno));
         }


=====================================
testsuite/tests/codeGen/should_gen_asm/AddMulX86.asm deleted
=====================================
@@ -1,46 +0,0 @@
-.section .text
-.align 8
-.align 8
-	.quad	8589934604
-	.quad	0
-	.long	14
-	.long	0
-.globl AddMulX86_f_info
-.type AddMulX86_f_info, @function
-AddMulX86_f_info:
-.LcAx:
-	leaq (%r14,%rsi,8),%rbx
-	jmp *(%rbp)
-	.size AddMulX86_f_info, .-AddMulX86_f_info
-.section .data
-.align 8
-.align 1
-.globl AddMulX86_f_closure
-.type AddMulX86_f_closure, @object
-AddMulX86_f_closure:
-	.quad	AddMulX86_f_info
-.section .text
-.align 8
-.align 8
-	.quad	8589934604
-	.quad	0
-	.long	14
-	.long	0
-.globl AddMulX86_g_info
-.type AddMulX86_g_info, @function
-AddMulX86_g_info:
-.LcAL:
-	leaq (%r14,%rsi,8),%rbx
-	jmp *(%rbp)
-	.size AddMulX86_g_info, .-AddMulX86_g_info
-.section .data
-.align 8
-.align 1
-.globl AddMulX86_g_closure
-.type AddMulX86_g_closure, @object
-AddMulX86_g_closure:
-	.quad	AddMulX86_g_info
-.section .note.GNU-stack,"", at progbits
-.ident "GHC 9.3.20220228"
-
-


=====================================
testsuite/tests/codeGen/should_gen_asm/AddMulX86.hs deleted
=====================================
@@ -1,12 +0,0 @@
-{-# LANGUAGE MagicHash #-}
-
-module AddMulX86 where
-
-import GHC.Exts
-
-f :: Int# -> Int# -> Int#
-f x y =
-    x +# (y *# 8#) -- Should result in a lea instruction, which we grep the assembly output for.
-
-g x y =
-    (y *# 8#) +# x  -- Should result in a lea instruction, which we grep the assembly output for.


=====================================
testsuite/tests/codeGen/should_gen_asm/all.T
=====================================
@@ -10,4 +10,3 @@ test('memset-unroll', is_amd64_codegen, compile_cmp_asm, ['cmm', ''])
 test('bytearray-memset-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
 test('bytearray-memcpy-unroll', is_amd64_codegen, compile_grep_asm, ['hs', True, ''])
 test('T18137', [when(opsys('darwin'), skip), only_ways(llvm_ways)], compile_grep_asm, ['hs', False, '-fllvm -split-sections'])
-test('AddMulX86', is_amd64_codegen, compile_cmp_asm, ['hs', '-dno-typeable-binds'])


=====================================
testsuite/tests/rts/pause-resume/pause_resume.c
=====================================
@@ -187,7 +187,7 @@ void pauseAndResumeViaThread
     )
 {
     OSThreadId threadId;
-    createOSThread(&threadId, "Pause and resume thread", &pauseAndResumeViaThread_helper, (void *)count);
+    createOSThread(&threadId, "pause-resume", &pauseAndResumeViaThread_helper, (void *)count);
 }
 
 const int TIMEOUT = 1000000; // 1 second



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d270e2408713763d0784b4f028174bbe09412320...0d68f927438e7fbeb7fbb725e0a2e42f8e66729d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d270e2408713763d0784b4f028174bbe09412320...0d68f927438e7fbeb7fbb725e0a2e42f8e66729d
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/20230110/8ba0d2ee/attachment-0001.html>


More information about the ghc-commits mailing list