[Git][ghc/ghc][wip/andreask/spec_lits] Allow SpecConstr to specialize for unboxed literals.

[Andreas Klebinger (@AndreasK)]

Andreas Klebinger pushed to branch wip/andreask/spec_lits at Glasgow Haskell Compiler / GHC


Commits:
46a3c818 by Andreas Klebinger at 2023-02-15T15:20:38+01:00
Allow SpecConstr to specialize for unboxed literals.

Fixes #22781

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/SpecConstr.hs
- + testsuite/tests/simplCore/should_compile/T22781.hs
- + testsuite/tests/simplCore/should_compile/T22781.stderr
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1534,6 +1534,9 @@ scExpr' env (Case scrut b ty alts)
                                   | not (single_alt && all deadArgOcc arg_occs)
                                   -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
                                      ScrutOcc (unitUFM dc arg_occs)
+                               LitAlt _
+                                  | not single_alt
+                                  -> ScrutOcc (emptyUFM)
                                _  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
                                      UnkOcc
           ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
@@ -2633,6 +2636,11 @@ argToPat in_scope val_env arg arg_occ
   -- Check for a constructor application
   -- NB: this *precedes* the Var case, so that we catch nullary constrs
 argToPat1 env in_scope val_env arg arg_occ _arg_str
+  | Just (ConVal (LitAlt lit) _args) <- isValue val_env arg
+  , mb_scrut_lit
+  = do {
+       ; return (True, Lit lit , []) }
+
   | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
   , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
   , Just arg_occs <- mb_scrut dc
@@ -2662,6 +2670,13 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
                             -> Just (repeat UnkOcc)
                             | otherwise
                             -> Nothing
+    mb_scrut_lit = case arg_occ of
+                ScrutOcc _  -> True
+                _other      | sc_force env || sc_keen (sc_opts env)
+                            -> True
+                            | otherwise
+                            -> False
+
     match_vals bangs (arg:args)
       | isTypeArg arg
       = NotMarkedStrict : match_vals bangs args


=====================================
testsuite/tests/simplCore/should_compile/T22781.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+
+module T22781 where
+
+import GHC.Exts
+
+bar = I# (go 0# 1#)
+  where
+    -- SpecConstr should generate a specialization for the call
+    --    (go 0# 1#) = $sgo
+    -- looking like
+    --    $sgo = / void -> 1#
+    go :: Int# -> Int# -> Int#
+    go 0# 1# = 1#
+    go _  0# = 3#
+    go n x = go n (x -# 1# )


=====================================
testsuite/tests/simplCore/should_compile/T22781.stderr
=====================================
@@ -0,0 +1,56 @@
+
+==================== Specialise ====================
+Result size of Specialise
+  = {terms: 37, types: 10, coercions: 0, joins: 0/0}
+
+Rec {
+go
+  = \ ds ds ->
+      case ds of ds {
+        __DEFAULT ->
+          case ds of ds {
+            __DEFAULT -> go ds (-# ds 1#);
+            0# -> 3#
+          };
+        0# ->
+          case ds of ds {
+            __DEFAULT -> go 0# (-# ds 1#);
+            0# -> 3#;
+            1# -> 1#
+          }
+      }
+end Rec }
+
+bar = case go 0# 1# of ds { __DEFAULT -> I# ds }
+
+
+
+
+==================== SpecConstr ====================
+Result size of SpecConstr
+  = {terms: 40, types: 13, coercions: 0, joins: 0/0}
+
+Rec {
+$sgo = \ void -> 1#
+
+go
+  = \ ds ds ->
+      case ds of ds {
+        __DEFAULT ->
+          case ds of ds {
+            __DEFAULT -> go ds (-# ds 1#);
+            0# -> 3#
+          };
+        0# ->
+          case ds of ds {
+            __DEFAULT -> go 0# (-# ds 1#);
+            0# -> 3#;
+            1# -> 1#
+          }
+      }
+end Rec }
+
+bar = case go 0# 1# of ds { __DEFAULT -> I# ds }
+
+
+


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -470,3 +470,4 @@ test('T22725', normal, compile, ['-O'])
 test('T22502', normal, compile, ['-O'])
 test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
 
+test('T22781', [grep_errmsg(r'.*go') ], compile, ['-O2 -ddump-spec -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46a3c818475f537fa73e5e61e1fcf4ed6ec630a3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/46a3c818475f537fa73e5e61e1fcf4ed6ec630a3
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/20230215/c2dc2bab/attachment-0001.html>