[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Mar 10 18:53:01 UTC 2023



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


Commits:
ec2d93eb by Sebastian Graf at 2023-03-10T10:18:54-05:00
DmdAnal: Fix a panic on OPAQUE and trivial/PAP RHS (#22997)

We should not panic in `add_demands` (now `set_lam_dmds`), because that code
path is legimitely taken for OPAQUE PAP bindings, as in T22997.

Fixes #22997.

- - - - -
5b4628ae by Sylvain Henry at 2023-03-10T10:19:34-05:00
JS: remove dead code for old integer-gmp

- - - - -
dbe1f848 by Josh Meredith at 2023-03-10T13:52:55-05:00
JS: Fix implementation of MK_JSVAL

- - - - -
298f6994 by Sebastian Graf at 2023-03-10T13:52:55-05:00
Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check

There is no need to run arity analysis and what not if we are not in a
Simplifier phase that eta-expands or if we don't want to eta-expand the
expression in the first place.

Purely a refactoring with the goal of improving compiler perf.

- - - - -


6 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- rts/js/rts.js
- + testsuite/tests/stranal/should_compile/T22997.hs
- testsuite/tests/stranal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1916,10 +1916,11 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
 
   -- Check for an OPAQUE function: see Note [OPAQUE pragma]
   -- In that case, trim off all boxity info from argument demands
+  -- and demand info on lambda binders
   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
   | isOpaquePragma (idInlinePragma fn)
   , let trimmed_rhs_dmds = map trimBoxity rhs_dmds
-  = (trimmed_rhs_dmds, add_demands trimmed_rhs_dmds rhs)
+  = (trimmed_rhs_dmds, set_lam_dmds trimmed_rhs_dmds rhs)
 
   -- Check that we have enough visible binders to match the
   -- threshold arity; if not, we won't do worker/wrapper
@@ -1939,8 +1940,8 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
     --   vcat [text "function:" <+> ppr fn
     --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
     --        , text "dmds after: " <+>  ppr arg_dmds' ]) $
-    (arg_dmds', add_demands arg_dmds' rhs)
-    -- add_demands: we must attach the final boxities to the lambda-binders
+    (arg_dmds', set_lam_dmds arg_dmds' rhs)
+    -- set_lam_dmds: we must attach the final boxities to the lambda-binders
     -- of the function, both because that's kosher, and because CPR analysis
     -- uses the info on the binders directly.
   where
@@ -2032,17 +2033,18 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
                  | positiveTopBudget bg_inner' = (bg_inner', dmd')
                  | otherwise                   = (bg_inner,  trimBoxity dmd)
 
-    add_demands :: [Demand] -> CoreExpr -> CoreExpr
+    set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr
     -- Attach the demands to the outer lambdas of this expression
-    add_demands [] e = e
-    add_demands (dmd:dmds) (Lam v e)
-      | isTyVar v = Lam v (add_demands (dmd:dmds) e)
-      | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)
-    add_demands dmds (Cast e co) = Cast (add_demands dmds e) co
+    set_lam_dmds (dmd:dmds) (Lam v e)
+      | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e)
+      | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e)
+    set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co
        -- This case happens for an OPAQUE function, which may look like
        --     f = (\x y. blah) |> co
        -- We give it strictness but no boxity (#22502)
-    add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
+    set_lam_dmds _ e = e
+       -- In the OPAQUE case, the list of demands at this point might be
+       -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997).
 
 finaliseLetBoxity
   :: AnalEnv


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1859,11 +1859,12 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
                 -> SimplM (ArityType, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 tryEtaExpandRhs env bind_cxt bndr rhs
-  | do_eta_expand           -- If the current manifest arity isn't enough
-                            --    (never true for join points)
-  , seEtaExpand env         -- and eta-expansion is on
-  , wantEtaExpansion rhs
-  = -- Do eta-expansion.
+  | seEtaExpand env         -- If Eta-expansion is on
+  , wantEtaExpansion rhs    -- and we'd like to eta-expand e
+  , do_eta_expand           -- and e's manifest arity is lower than
+                            --     what it could be
+                            --     (never true for join points)
+  =                         -- Do eta-expansion.
     assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $
        -- assert: this never happens for join points; see GHC.Core.Opt.Arity
        --         Note [Do not eta-expand join points]


=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -115,8 +115,8 @@ genCommonCppDefs profiling = mconcat
 
   -- GHCJS.Prim.JSVal
   , if profiling
-      then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"
-      else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"
+      then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"
+      else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n"
   ,  "#define JSVAL_VAL(x) ((x).d1)\n"
 
   -- GHCJS.Prim.JSException


=====================================
rts/js/rts.js
=====================================
@@ -365,14 +365,7 @@ function h$printReg(r) {
     } else if(r.f.t === h$ct_blackhole && r.x) {
       return ("blackhole: -> " + h$printReg({ f: r.x.x1, d: r.d1.x2 }) + ")");
     } else {
-      var iv = "";
-      if(r.f.n === "integer-gmp:GHC.Integer.Type.Jp#" ||
-      r.f.n === "integer-gmp:GHC.Integer.Type.Jn#") {
-        iv = ' [' + r.d1.join(',') + '](' + h$ghcjsbn_showBase(r.d1, 10) + ')'
-      } else if(r.f.n === "integer-gmp:GHC.Integer.Type.S#") {
-        iv = ' (S: ' + r.d1 + ')';
-      }
-      return ((r.alloc ? r.alloc + ': ' : '') + r.f.n + " (" + h$closureTypeName(r.f.t) + ", " + r.f.a + ")" + iv);
+      return ((r.alloc ? r.alloc + ': ' : '') + r.f.n + " (" + h$closureTypeName(r.f.t) + ", " + r.f.a + ")");
     }
   } else if(typeof r === 'object') {
     var res = h$collectProps(r);
@@ -536,14 +529,7 @@ function h$dumpStackTop(stack, start, sp) {
           if(s.f.t === h$ct_blackhole && s.d1 && s.d1.x1 && s.d1.x1.n) {
             h$log("stack[" + i + "] = blackhole -> " + s.d1.x1.n);
           } else {
-            var iv = "";
-            if(s.f.n === "integer-gmp:GHC.Integer.Type.Jp#" ||
-            s.f.n === "integer-gmp:GHC.Integer.Type.Jn#") {
-              iv = ' [' + s.d1.join(',') + '](' + h$ghcjsbn_showBase(s.d1, 10) + ')'
-            } else if(s.f.n === "integer-gmp:GHC.Integer.Type.S#") {
-              iv = ' (S: ' + s.d1 + ')';
-            }
-            h$log("stack[" + i + "] = -> " + (s.alloc ? s.alloc + ': ' : '') + s.f.n + " (" + h$closureTypeName(s.f.t) + ", a: " + s.f.a + ")" + iv);
+            h$log("stack[" + i + "] = -> " + (s.alloc ? s.alloc + ': ' : '') + s.f.n + " (" + h$closureTypeName(s.f.t) + ", a: " + s.f.a + ")");
           }
         }
       } else if(h$isInstanceOf(s,h$MVar)) {


=====================================
testsuite/tests/stranal/should_compile/T22997.hs
=====================================
@@ -0,0 +1,9 @@
+module T22997 where
+
+{-# OPAQUE trivial #-}
+trivial :: Int -> Int
+trivial = succ
+
+{-# OPAQUE pap #-}
+pap :: Integer -> Integer
+pap = (42 +)


=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -88,3 +88,5 @@ test('EtaExpansion', normal, compile, [''])
 test('T22039', normal, compile, [''])
 # T22388: Should see $winteresting but not $wboring
 test('T22388', [ grep_errmsg(r'^\S+\$w\S+') ], compile, ['-dsuppress-uniques -ddump-simpl'])
+# T22997: Just a panic that should not happen
+test('T22997', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32163a1893061a4cd22974cf27280d68c51b2861...298f69943c904803ed5d515af1143cdabdc93285

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32163a1893061a4cd22974cf27280d68c51b2861...298f69943c904803ed5d515af1143cdabdc93285
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/20230310/13fa2ecb/attachment-0001.html>


More information about the ghc-commits mailing list