[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: hadrian: enable -fprof-late only for profiling ways

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Sep 16 12:07:36 UTC 2022



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


Commits:
7a0380ae by Cheng Shao at 2022-09-16T08:06:56-04:00
hadrian: enable -fprof-late only for profiling ways

- - - - -
65529183 by Cheng Shao at 2022-09-16T08:06:56-04:00
hadrian: add late_ccs flavour transformer

- - - - -
7a371ef2 by Cheng Shao at 2022-09-16T08:06:59-04:00
configure: remove unused program checks

- - - - -
f07fce6a by Pierre Le Marre at 2022-09-16T08:07:02-04:00
Update to Unicode 15.0

- - - - -
b7a03077 by Bodigrim at 2022-09-16T08:07:05-04:00
Avoid partial head and tail in ghc-heap; replace with total pattern-matching

- - - - -
52589b2b by Cheng Shao at 2022-09-16T08:07:07-04:00
hadrian: relax Cabal upper bound to allow building with Cabal-3.8

A follow up of !8910.

- - - - -
6ac52576 by Alexis King at 2022-09-16T08:07:09-04:00
Add links to the continuations haddocks in the docs for each primop

fixes #22176

- - - - -


18 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- configure.ac
- docs/users_guide/9.6.1-notes.rst
- hadrian/hadrian.cabal
- hadrian/src/Flavour.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/unicode001.hs
- libraries/base/tests/unicode002.stdout
- libraries/base/tests/unicode003.stdout
- libraries/base/tools/ucd2haskell/README.md
- libraries/base/tools/ucd2haskell/unicode_version
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2634,7 +2634,9 @@ primop  MaskStatus "getMaskingState#" GenPrimOp
 
 ------------------------------------------------------------------------
 section "Continuations"
-  { These operations provide access to first-class delimited continuations,
+  { #continuations#
+
+    These operations provide access to first-class delimited continuations,
     which allow a computation to access and manipulate portions of its
     /current continuation/. Operationally, they are implemented by direct
     manipulation of the RTS call stack, which may provide significant
@@ -2791,9 +2793,11 @@ section "Continuations"
 ------------------------------------------------------------------------
 
 primtype PromptTag# a
+   { See "GHC.Prim#continuations". }
 
 primop  NewPromptTagOp "newPromptTag#" GenPrimOp
         State# RealWorld -> (# State# RealWorld, PromptTag# a #)
+   { See "GHC.Prim#continuations". }
    with
    out_of_line = True
    has_side_effects = True
@@ -2802,6 +2806,7 @@ primop  PromptOp "prompt#" GenPrimOp
         PromptTag# a
      -> (State# RealWorld -> (# State# RealWorld, a #))
      -> State# RealWorld -> (# State# RealWorld, a #)
+   { See "GHC.Prim#continuations". }
    with
    strictness = { \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv }
    out_of_line = True
@@ -2813,6 +2818,7 @@ primop  Control0Op "control0#" GenPrimOp
           -> State# RealWorld -> (# State# RealWorld, a #))
          -> State# RealWorld -> (# State# RealWorld, a #))
      -> State# RealWorld -> (# State# RealWorld, p #)
+   { See "GHC.Prim#continuations". }
    with
    strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv }
    out_of_line = True


=====================================
configure.ac
=====================================
@@ -745,11 +745,6 @@ dnl ** check for tar
 dnl   if GNU tar is named gtar, look for it first.
 AC_PATH_PROGS(TarCmd,gnutar gtar tar,tar)
 
-dnl ** check for compressors
-AC_PATH_PROGS(Bzip2Cmd,bzip2, bzip2)
-AC_PATH_PROGS(GzipCmd,gzip, gzip)
-AC_PATH_PROGS(XzCmd,pxz xz, xz)
-
 dnl ** check for patch
 dnl if GNU patch is named gpatch, look for it first
 AC_PATH_PROGS(PatchCmd,gpatch patch, patch)


=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -91,7 +91,7 @@ Runtime system
   no safe API to access this functionality is provided anywhere in ``base``.
   Instead, the ``prompt#`` and ``control0#`` primops are intended to be consumed
   by library authors directly, who may wrap them a safe API that maintains the
-  necessary invariants. See the documentation in ``GHC.Exts`` for more details.
+  necessary invariants. See the documentation in ``GHC.Prim`` for more details.
 
 ``base`` library
 ~~~~~~~~~~~~~~~~


=====================================
hadrian/hadrian.cabal
=====================================
@@ -147,7 +147,7 @@ executable hadrian
                        , BangPatterns
     other-extensions:    MultiParamTypeClasses
                        , TypeFamilies
-    build-depends:       Cabal                >= 3.2     && < 3.7
+    build-depends:       Cabal                >= 3.2     && < 3.9
                        , base                 >= 4.8     && < 5
                        , bytestring           >= 0.10    && < 0.12
                        , containers           >= 0.5     && < 0.7


=====================================
hadrian/src/Flavour.hs
=====================================
@@ -56,6 +56,7 @@ flavourTransformers = M.fromList
     , "debug_stage1_ghc" =: debugGhc stage0InTree
     , "lint" =: enableLinting
     , "haddock" =: enableHaddock
+    , "late_ccs" =: enableLateCCS
     ]
   where (=:) = (,)
 
@@ -237,6 +238,7 @@ enableIPE = addArgs
 enableLateCCS :: Flavour -> Flavour
 enableLateCCS = addArgs
   $ notStage0 ? builder (Ghc CompileHs)
+  ? ((Profiling `wayUnit`) <$> getWay)
   ? arg "-fprof-late"
 
 -- | Enable assertions for the stage2 compiler
@@ -525,4 +527,3 @@ builderSetting =
         stages = map (\stg -> (stageString stg, stg)) allStages
 
         pkgs = map (\pkg -> (pkgName pkg, pkg)) (ghcPackages ++ userPackages)
-


=====================================
libraries/base/GHC/Unicode/Internal/Char/UnicodeData/GeneralCategory.hs
=====================================
The diff for this file was not included because it is too large.

=====================================
libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleLowerCaseMapping.hs
=====================================
@@ -1,5 +1,5 @@
 -- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell,
--- with data from: https://www.unicode.org/Public/14.0.0/ucd/UnicodeData.txt.
+-- with data from: https://www.unicode.org/Public/15.0.0/ucd/UnicodeData.txt.
 
 {-# LANGUAGE NoImplicitPrelude, LambdaCase #-}
 {-# OPTIONS_HADDOCK hide #-}


=====================================
libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleTitleCaseMapping.hs
=====================================
@@ -1,5 +1,5 @@
 -- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell,
--- with data from: https://www.unicode.org/Public/14.0.0/ucd/UnicodeData.txt.
+-- with data from: https://www.unicode.org/Public/15.0.0/ucd/UnicodeData.txt.
 
 {-# LANGUAGE NoImplicitPrelude, LambdaCase #-}
 {-# OPTIONS_HADDOCK hide #-}


=====================================
libraries/base/GHC/Unicode/Internal/Char/UnicodeData/SimpleUpperCaseMapping.hs
=====================================
@@ -1,5 +1,5 @@
 -- DO NOT EDIT: This file is automatically generated by the internal tool ucd2haskell,
--- with data from: https://www.unicode.org/Public/14.0.0/ucd/UnicodeData.txt.
+-- with data from: https://www.unicode.org/Public/15.0.0/ucd/UnicodeData.txt.
 
 {-# LANGUAGE NoImplicitPrelude, LambdaCase #-}
 {-# OPTIONS_HADDOCK hide #-}


=====================================
libraries/base/GHC/Unicode/Internal/Version.hs
=====================================
@@ -19,8 +19,8 @@ where
 import {-# SOURCE #-} Data.Version
 
 -- | Version of Unicode standard used by @base@:
--- [14.0.0](https://www.unicode.org/versions/Unicode14.0.0/).
+-- [15.0.0](https://www.unicode.org/versions/Unicode15.0.0/).
 --
 -- @since 4.15.0.0
 unicodeVersion :: Version
-unicodeVersion = makeVersion [14, 0, 0]
+unicodeVersion = makeVersion [15, 0, 0]


=====================================
libraries/base/changelog.md
=====================================
@@ -29,6 +29,7 @@
     is now exported from `Prelude`. See [CLC #50](https://github.com/haskell/core-libraries-committee/issues/50)
     for the related discussion,
     as well as [the migration guide](https://github.com/haskell/core-libraries-committee/blob/main/guides/export-lifta2-prelude.md)
+  * Update to Unicode 15.0.0.
 
 ## 4.17.0.0 *August 2022*
 


=====================================
libraries/base/tests/unicode001.hs
=====================================
@@ -12,7 +12,7 @@ main = do
   do_char char = s ++ (take (12-length s) (repeat ' ')) ++ concat (map f bs)
     where
           s = show char
-          bs = map ($char) functions
+          bs = map ($ char) functions
           f True  = "X     "
           f False = "      "
 


=====================================
libraries/base/tests/unicode002.stdout
=====================================
@@ -3314,7 +3314,7 @@ Code C P S U L A D
 3312 F F F F F F F
 3313 F T F F F T F
 3314 F T F F F T F
-3315 F F F F F F F
+3315 F T F F F F F
 3316 F F F F F F F
 3317 F F F F F F F
 3318 F F F F F F F
@@ -3789,7 +3789,7 @@ Code C P S U L A D
 3787 F T F F F F F
 3788 F T F F F F F
 3789 F T F F F F F
-3790 F F F F F F F
+3790 F T F F F F F
 3791 F F F F F F F
 3792 F T F F F F F
 3793 F T F F F F F


=====================================
libraries/base/tests/unicode003.stdout
=====================================
@@ -32,11 +32,11 @@ b54,-1748855834,-1637297928
 bb8,-1397865929,883567028
 c1c,-264170711,891256304
 c80,2137024553,478728044
-ce4,-991366506,1583915976
+ce4,-1660460875,1583915976
 d48,-651373686,-1004871068
 dac,-1169615531,-988897408
 e10,1814409961,155596444
-e74,135711270,-609427496
+e74,963650286,-609427496
 ed8,-1416017146,-1439222892
 f3c,1403902424,1433030608
 fa0,299354809,273668620
@@ -692,7 +692,7 @@ ffdc,-2015459986,1906523440
 10d88,-847508383,-1808919772
 10dec,-847508383,538515008
 10e50,-188198045,1503265372
-10eb4,-1034104055,-491064168
+10eb4,-1370226063,-491064168
 10f18,-350286230,-1694282284
 10f7c,1484313900,856053392
 10fe0,-723679588,-588754868
@@ -701,7 +701,7 @@ ffdc,-2015459986,1906523440
 1110c,1655903282,449049760
 11170,-1051595,32149756
 111d4,2109886511,1120445560
-11238,-337373458,1455451956
+11238,-659711824,1455451956
 1129c,-1148635252,-368614032
 11300,696218094,-2068618516
 11364,-686461423,208748104
@@ -723,7 +723,7 @@ ffdc,-2015459986,1906523440
 119a4,-1139814714,593543304
 11a08,1795222972,-262351708
 11a6c,307339100,1598197440
-11ad0,1613469971,-1283076388
+11ad0,-1522264485,-1283076388
 11b34,-847508383,-177855464
 11b98,-847508383,487104084
 11bfc,-2065396652,888655120
@@ -733,8 +733,8 @@ ffdc,-2015459986,1906523440
 11d8c,1348516795,1770597664
 11df0,-847508383,1176409468
 11e54,-847508383,-1707561992
-11eb8,-1502831374,1494051508
-11f1c,-847508383,367208176
+11eb8,2081578339,1494051508
+11f1c,-1149259987,367208176
 11f80,1106256227,1888008812
 11fe4,757618445,-1421783352
 12048,657752308,332029284
@@ -787,8 +787,8 @@ ffdc,-2015459986,1906523440
 132a4,657752308,-302543992
 13308,657752308,-1755701852
 1336c,657752308,-1080401472
-133d0,622961565,1547985372
-13434,1770698299,-189064936
+133d0,1375666284,1547985372
+13434,934320124,-189064936
 13498,-847508383,-366597292
 134fc,-847508383,-1290482672
 13560,-847508383,410098124
@@ -1107,8 +1107,8 @@ ffdc,-2015459986,1906523440
 1afa4,-826749161,1555287688
 1b008,657752308,-1636146524
 1b06c,657752308,-2023206720
-1b0d0,-993675331,-289721124
-1b134,-1949537464,1982839320
+1b0d0,-574234906,-289721124
+1b134,-1242452955,1982839320
 1b198,657752308,1394012244
 1b1fc,657752308,-1653165296
 1b260,657752308,-137343284
@@ -1193,8 +1193,8 @@ ffdc,-2015459986,1906523440
 1d13c,-898907559,-872375856
 1d1a0,-1152492591,-1201120244
 1d204,-1459916519,-1252799320
-1d268,-847508383,-14303932
-1d2cc,143940813,-646470432
+1d268,1804045749,-14303932
+1d2cc,-640919574,-646470432
 1d330,-329414484,1932561468
 1d394,-847508383,-1734110024
 1d3f8,170379721,-333552908
@@ -1225,11 +1225,11 @@ ffdc,-2015459986,1906523440
 1ddbc,-847508383,-868111280
 1de20,-847508383,1044035212
 1de84,-847508383,-1630701272
-1dee8,574970994,-117287484
+1dee8,1239944610,-117287484
 1df4c,-847508383,387643232
 1dfb0,-62539639,-1756483396
-1e014,906881201,-65223112
-1e078,-847508383,-1946563980
+1e014,702354581,-65223112
+1e078,1024183577,-1946563980
 1e0dc,885955124,-210392528
 1e140,590739849,1173406764
 1e1a4,-847508383,644941960
@@ -1240,7 +1240,7 @@ ffdc,-2015459986,1906523440
 1e398,-847508383,-478480812
 1e3fc,-847508383,-503630576
 1e460,-847508383,1606163660
-1e4c4,-847508383,180346728
+1e4c4,1412498216,180346728
 1e528,-847508383,-1797992572
 1e58c,-847508383,2096370976
 1e5f0,-847508383,-2094838404
@@ -1286,17 +1286,17 @@ ffdc,-2015459986,1906523440
 1f590,-1105473175,328132636
 1f5f4,-1105473175,2066842712
 1f658,-1105473175,-1920516332
-1f6bc,-439945135,1904745808
-1f720,-270299271,2006428044
-1f784,-1856991071,-343818712
+1f6bc,1645245961,1904745808
+1f720,-1162559895,2006428044
+1f784,-702101815,-343818712
 1f7e8,1976628113,-898518844
 1f84c,471140881,282876512
 1f8b0,-10438759,-395554372
 1f914,-1105473175,-679784648
 1f978,-1105473175,1183875956
 1f9dc,-1105473175,1885428528
-1fa40,-1534740639,2004332332
-1faa4,-1131042383,2017661832
+1fa40,923756505,2004332332
+1faa4,467344305,2017661832
 1fb08,-1105473175,1091204516
 1fb6c,1120513513,-117061184
 1fbd0,1887269219,1232484828
@@ -1778,7 +1778,7 @@ ffdc,-2015459986,1906523440
 2b5c0,657752308,1930785196
 2b624,657752308,-149225208
 2b688,657752308,-88958940
-2b6ec,-1998519121,728275264
+2b6ec,-324656038,728275264
 2b750,657752308,-1891904164
 2b7b4,657752308,58192280
 2b818,-276965978,1939972820
@@ -2014,49 +2014,49 @@ ffdc,-2015459986,1906523440
 311f0,657752308,360595836
 31254,657752308,-488110088
 312b8,657752308,-889624908
-3131c,-56393871,2019611376
-31380,-847508383,-1213041044
-313e4,-847508383,-1135936824
-31448,-847508383,1696461156
-314ac,-847508383,1125471872
-31510,-847508383,680032156
-31574,-847508383,1996493528
-315d8,-847508383,283544724
-3163c,-847508383,-1902150960
-316a0,-847508383,-962983156
-31704,-847508383,872440232
-31768,-847508383,212618308
-317cc,-847508383,-1056997408
-31830,-847508383,-296270532
-31894,-847508383,-1547695688
-318f8,-847508383,1004955636
-3195c,-847508383,621756848
-319c0,-847508383,1650466220
-31a24,-847508383,-408089336
-31a88,-847508383,-1063437276
-31aec,-847508383,1314628928
-31b50,-847508383,-807380644
-31bb4,-847508383,-1248342632
-31c18,-847508383,-319457580
-31c7c,-847508383,-1276547696
-31ce0,-847508383,1954980172
-31d44,-847508383,-1819820568
-31da8,-847508383,333403140
-31e0c,-847508383,-2025999968
-31e70,-847508383,1747736060
-31ed4,-847508383,-1470334600
-31f38,-847508383,-1433450956
-31f9c,-847508383,1476839536
-32000,-847508383,120898540
-32064,-847508383,-679398584
-320c8,-847508383,-782284572
-3212c,-847508383,1594699520
-32190,-847508383,562228252
-321f4,-847508383,1176514648
-32258,-847508383,-461262060
-322bc,-847508383,922315088
-32320,-847508383,-238903924
-32384,-847508383,-2021244376
+3131c,-15536511,2019611376
+31380,657752308,-1213041044
+313e4,657752308,-1135936824
+31448,657752308,1696461156
+314ac,657752308,1125471872
+31510,657752308,680032156
+31574,657752308,1996493528
+315d8,657752308,283544724
+3163c,657752308,-1902150960
+316a0,657752308,-962983156
+31704,657752308,872440232
+31768,657752308,212618308
+317cc,657752308,-1056997408
+31830,657752308,-296270532
+31894,657752308,-1547695688
+318f8,657752308,1004955636
+3195c,657752308,621756848
+319c0,657752308,1650466220
+31a24,657752308,-408089336
+31a88,657752308,-1063437276
+31aec,657752308,1314628928
+31b50,657752308,-807380644
+31bb4,657752308,-1248342632
+31c18,657752308,-319457580
+31c7c,657752308,-1276547696
+31ce0,657752308,1954980172
+31d44,657752308,-1819820568
+31da8,657752308,333403140
+31e0c,657752308,-2025999968
+31e70,657752308,1747736060
+31ed4,657752308,-1470334600
+31f38,657752308,-1433450956
+31f9c,657752308,1476839536
+32000,657752308,120898540
+32064,657752308,-679398584
+320c8,657752308,-782284572
+3212c,657752308,1594699520
+32190,657752308,562228252
+321f4,657752308,1176514648
+32258,657752308,-461262060
+322bc,657752308,922315088
+32320,657752308,-238903924
+32384,-696549012,-2021244376
 323e8,-847508383,1145582788
 3244c,-847508383,1664085600
 324b0,-847508383,-2133158468


=====================================
libraries/base/tools/ucd2haskell/README.md
=====================================
@@ -27,7 +27,7 @@ with Python.
 
 __Warning:__ A Python version with the _exact same Unicode version_ is required.
 
-# GHC
+## GHC
 
 Check the properties of all the characters.
 
@@ -37,7 +37,7 @@ ghc -O2 tests/export_all_chars.hs
 python3 tests/check_all_chars.py tests/all_chars.csv
 ```
 
-# GHC tests data
+## GHC tests data
 
 Check the Unicode test data (`unicodeNNN.stdout`).
 


=====================================
libraries/base/tools/ucd2haskell/unicode_version
=====================================
@@ -1 +1 @@
-VERSION="14.0.0"
+VERSION="15.0.0"


=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -71,7 +71,6 @@ import GHC.Exts.Heap.Utils
 import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
 import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
 
-import Control.Monad
 import Data.Bits
 import Foreign
 import GHC.Exts
@@ -221,135 +220,119 @@ getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
         t | t >= THUNK && t <= THUNK_STATIC -> do
             pure $ ThunkClosure itbl pts npts
 
-        THUNK_SELECTOR -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
-            pure $ SelectorClosure itbl (head pts)
+        THUNK_SELECTOR -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+            hd : _ -> pure $ SelectorClosure itbl hd
 
         t | t >= FUN && t <= FUN_STATIC -> do
             pure $ FunClosure itbl pts npts
 
-        AP -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to AP"
-            -- We expect at least the arity, n_args, and fun fields
-            unless (length payloadWords >= 2) $
-                fail "Expected at least 2 raw words to AP"
-            let splitWord = payloadWords !! 0
-            pure $ APClosure itbl
+        AP -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to AP"
+            hd : tl -> case payloadWords of
+                -- We expect at least the arity, n_args, and fun fields
+                splitWord : _ : _ ->
+                    pure $ APClosure itbl
 #if defined(WORDS_BIGENDIAN)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-                (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
 #else
-                (fromIntegral splitWord)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
 #endif
-                (head pts) (tail pts)
-
-        PAP -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to PAP"
-            -- We expect at least the arity, n_args, and fun fields
-            unless (length payloadWords >= 2) $
-                fail "Expected at least 2 raw words to PAP"
-            let splitWord = payloadWords !! 0
-            pure $ PAPClosure itbl
+                        hd tl
+                _ -> fail "Expected at least 2 raw words to AP"
+
+        PAP -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to PAP"
+            hd : tl -> case payloadWords of
+                -- We expect at least the arity, n_args, and fun fields
+                splitWord : _ : _ ->
+                    pure $ PAPClosure itbl
 #if defined(WORDS_BIGENDIAN)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-                (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
 #else
-                (fromIntegral splitWord)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
 #endif
-                (head pts) (tail pts)
-
-        AP_STACK -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to AP_STACK"
-            pure $ APStackClosure itbl (head pts) (tail pts)
-
-        IND -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to IND"
-            pure $ IndClosure itbl (head pts)
-
-        IND_STATIC -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to IND_STATIC"
-            pure $ IndClosure itbl (head pts)
-
-        BLACKHOLE -> do
-            unless (length pts >= 1) $
-                fail "Expected at least 1 ptr argument to BLACKHOLE"
-            pure $ BlackholeClosure itbl (head pts)
-
-        BCO -> do
-            unless (length pts >= 3) $
-                fail $ "Expected at least 3 ptr argument to BCO, found "
-                        ++ show (length pts)
-            unless (length payloadWords >= 4) $
-                fail $ "Expected at least 4 words to BCO, found "
-                        ++ show (length payloadWords)
-            let splitWord = payloadWords !! 3
-            pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
+                        hd tl
+                _ -> fail "Expected at least 2 raw words to PAP"
+
+        AP_STACK -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to AP_STACK"
+            hd : tl -> pure $ APStackClosure itbl hd tl
+
+        IND -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to IND"
+            hd : _ -> pure $ IndClosure itbl hd
+
+        IND_STATIC -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
+            hd : _ -> pure $ IndClosure itbl hd
+
+        BLACKHOLE -> case pts of
+            [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
+            hd : _ -> pure $ BlackholeClosure itbl hd
+
+        BCO -> case pts of
+            pts0 : pts1 : pts2 : _ -> case payloadWords of
+                _ : _ : _ : splitWord : payloadRest ->
+                    pure $ BCOClosure itbl pts0 pts1 pts2
 #if defined(WORDS_BIGENDIAN)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-                (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
 #else
-                (fromIntegral splitWord)
-                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                        (fromIntegral splitWord)
+                        (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
 #endif
-                (drop 4 payloadWords)
+                        payloadRest
+                _ -> fail $ "Expected at least 4 words to BCO, found "
+                            ++ show (length payloadWords)
+            _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
+                        ++ show (length pts)
 
-        ARR_WORDS -> do
-            unless (length payloadWords >= 1) $
-                fail $ "Expected at least 1 words to ARR_WORDS, found "
+        ARR_WORDS -> case payloadWords of
+            [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
                         ++ show (length payloadWords)
-            pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
+            hd : tl -> pure $ ArrWordsClosure itbl hd tl
 
-        t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
-            unless (length payloadWords >= 2) $
-                fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+        t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+            p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
+            _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
                         ++ "found " ++ show (length payloadWords)
-            pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
 
-        t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
-            unless (length payloadWords >= 1) $
-                fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+        t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+            [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
                         ++ "found " ++ show (length payloadWords)
-            pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
+            hd : _ -> pure $ SmallMutArrClosure itbl hd pts
 
-        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
-            unless (length pts >= 1) $
-                fail $ "Expected at least 1 words to MUT_VAR, found "
+        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
+            [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
                         ++ show (length pts)
-            pure $ MutVarClosure itbl (head pts)
+            hd : _ -> pure $ MutVarClosure itbl hd
 
-        t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
-            unless (length pts >= 3) $
-                fail $ "Expected at least 3 ptrs to MVAR, found "
+        t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
+            pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
+            _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
                         ++ show (length pts)
-            pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
 
         BLOCKING_QUEUE ->
             pure $ OtherClosure itbl pts rawHeapWords
-        --    pure $ BlockingQueueClosure itbl
-        --        (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
 
-        --  pure $ OtherClosure itbl pts rawHeapWords
-        --
-        WEAK -> do
-            pure $ WeakClosure
+        WEAK -> case pts of
+            pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
                 { info = itbl
-                , cfinalizers = pts !! 0
-                , key = pts !! 1
-                , value = pts !! 2
-                , finalizer = pts !! 3
-                , weakLink = case drop 4 pts of
+                , cfinalizers = pts0
+                , key = pts1
+                , value = pts2
+                , finalizer = pts3
+                , weakLink = case rest of
                            []  -> Nothing
                            [p] -> Just p
-                           _   -> error $ "Expected 4 or 5 words in WEAK, found " ++ show (length pts)
+                           _   -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
                 }
+            _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
         TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other)  <- pts
                 -> withArray rawHeapWords (\ptr -> do
                     fields <- FFIClosures.peekTSOFields decodeCCS ptr


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc
=====================================
@@ -110,11 +110,7 @@ parse (Ptr addr) = if not . all (>0) . fmap length $ [p,m,occ]
     (m, occ)
         = (intercalate "." $ reverse modWords, occWord)
         where
-        (modWords, occWord) =
-            if length rest1 < 1 --  XXXXXXXXx YUKX
-                --then error "getConDescAddress:parse:length rest1 < 1"
-                then parseModOcc [] []
-                else parseModOcc [] (tail rest1)
+        (modWords, occWord) = parseModOcc [] (drop 1 rest1)
     -- We only look for dots if str could start with a module name,
     -- i.e. if it starts with an upper case character.
     -- Otherwise we might think that "X.:->" is the module name in



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc2edced40854e169bd55b04e21470e0bb447bb5...6ac525764bf1fa4fadd51f9c81cdeb45fa90f859

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cc2edced40854e169bd55b04e21470e0bb447bb5...6ac525764bf1fa4fadd51f9c81cdeb45fa90f859
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/20220916/52b3c791/attachment-0001.html>


More information about the ghc-commits mailing list