[Git][ghc/ghc][wip/refactor-demand] fix regression

[Sebastian Graf]

Sebastian Graf pushed to branch wip/refactor-demand at Glasgow Haskell Compiler / GHC


Commits:
aabd8a4c by Sebastian Graf at 2020-11-16T21:16:02+01:00
fix regression

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Types/Demand.hs


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -78,12 +78,12 @@ dmdAnalTopBind env (NonRec id rhs)
   = ( extendAnalEnv TopLevel env id sig
     , NonRec (setIdStrictness id sig) rhs')
   where
-    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs
+    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs
 
 dmdAnalTopBind env (Rec pairs)
   = (env', Rec pairs')
   where
-    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs
+    (env', _, pairs')  = dmdFix TopLevel env topSubDmd pairs
                 -- We get two iterations automatically
                 -- c.f. the NonRec case above
 
@@ -263,7 +263,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
 dmdAnal' env dmd (Case scrut case_bndr ty alts)
   = let      -- Case expression with multiple alternatives
         (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
-        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
+        (scrut_ty, scrut')   = dmdAnal env topSubDmd scrut
         (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
                                -- NB: Base case is botDmdType, for empty case alternatives
                                --     This is a unit for lubDmdType, and the right result
@@ -668,7 +668,7 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
 -- a call demand of @rhs_arity@
 -- See Historical Note [Product demands for function body]
 mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand
-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd
+mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd
 
 -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
 -- whether we should process the binding up (body before rhs) or down (rhs


=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1724,7 +1724,7 @@ calcSpecStrictness fn qvars pats
     go env _      _                = env
 
     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
-    go_one env d               (Var v) = extendVarEnv_C plusDmd env v d
+    go_one env d          (Var v) = extendVarEnv_C plusDmd env v d
     go_one env (_n :* cd) e -- NB: _n does not have to be strict
       | (Var _, args) <- collectArgs e
       , Just ds <- viewProd (length args) cd


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.Types.Demand (
     -- * Demands
     Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd,
     -- ** Algebra
-    absDmd, topDmd, botDmd, seqDmd,
+    absDmd, topDmd, botDmd, seqDmd, topSubDmd,
     -- *** Least upper bound
     lubCard, lubDmd, lubSubDmd,
     -- *** Plus
@@ -29,7 +29,7 @@ module GHC.Types.Demand (
     isAbsDmd, isUsedOnceDmd, isStrUsedDmd,
     isTopDmd, isSeqDmd, isWeakDmd,
     -- ** Special demands
-    evalDmd, cleanEvalDmd, cleanEvalProdDmd,
+    evalDmd,
     -- *** Demands used in PrimOp signatures
     lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
     -- ** Other @Demand@ operations
@@ -311,7 +311,7 @@ polyDmd C_10 = C_10 :* poly10
 -- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a
 -- polymorphic demand will never unbox.
 mkProd :: [Demand] -> SubDemand
-mkProd [] = botSubDmd
+mkProd [] = seqSubDmd
 mkProd ds@(n:*sd : _)
   | want_to_simplify n, all (== polyDmd n) ds = sd
   | otherwise                                 = Prod ds
@@ -456,13 +456,7 @@ isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd
     is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative]
 
 evalDmd :: Demand
-evalDmd = C_1N :* cleanEvalDmd
-
-cleanEvalDmd :: SubDemand
-cleanEvalDmd = topSubDmd
-
-cleanEvalProdDmd :: Arity -> SubDemand
-cleanEvalProdDmd n = Prod (replicate n topDmd)
+evalDmd = C_1N :* topSubDmd
 
 -- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@.
 -- Called exactly once.
@@ -558,7 +552,9 @@ addCaseBndrDmd (n :* sd) alt_dmds
   | isAbs n   = alt_dmds
   | otherwise = zipWith plusDmd ds alt_dmds -- fuse ds!
   where
-    Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call
+    sd' | isStrict n = sd
+        | otherwise  = multSubDmd C_01 sd
+    Just ds = viewProd (length alt_dmds) sd' -- Guaranteed not to be a call
 
 argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]
 -- ^ See Note [Computing one-shot info]
@@ -578,7 +574,7 @@ argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args
 argOneShots :: Demand          -- ^ depending on saturation
             -> [OneShotInfo]
 -- ^ See Note [Computing one-shot info]
-argOneShots (_ :* sd) = go sd
+argOneShots (n :* sd) = go (multSubDmd n sd) -- See Note [Call demands are relative]
   where
     go (Call n sd)
       | isUsedOnce n = OneShotLam    : go sd



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aabd8a4cb01328e8b885c9a3608a229a69c295ff
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/20201116/9b3a2f9d/attachment-0001.html>