[Git][ghc/ghc][wip/sjakobi/nondetfolds] Use a strict fold in splitFVs

[Simon Jakobi]

Simon Jakobi pushed to branch wip/sjakobi/nondetfolds at Glasgow Haskell Compiler / GHC


Commits:
fe485655 by Simon Jakobi at 2020-04-02T15:14:51+02:00
Use a strict fold in splitFVs

- - - - -


2 changed files:

- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Unique/FM.hs


Changes:

=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -785,16 +785,23 @@ cleanUseDmd_maybe _                     = Nothing
 splitFVs :: Bool   -- Thunk
          -> DmdEnv -> (DmdEnv, DmdEnv)
 splitFVs is_thunk rhs_fvs
-  | is_thunk  = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs
-                -- It's OK to use nonDetFoldUFM_Directly because we
+  | is_thunk  = strictPairToTuple $
+                nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs
+                -- It's OK to use a non-deterministic fold because we
                 -- immediately forget the ordering by putting the elements
                 -- in the envs again
   | otherwise = partitionVarEnv isWeakDmd rhs_fvs
   where
-    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv)
-      | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv)
-      | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
-                    , addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs }) )
+    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv)
+      | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv
+      | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })
+                    :*:
+                    addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs })
+
+data StrictPair a b = !a :*: !b
+
+strictPairToTuple :: StrictPair a b -> (a, b)
+strictPairToTuple (x :*: y) = (x, y)
 
 data TypeShape = TsFun TypeShape
                | TsProd [TypeShape]


=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Types.Unique.FM (
         intersectUFM_C,
         disjointUFM,
         equalKeysUFM,
-        nonDetStrictFoldUFM, foldUFM, nonDetFoldUFM_Directly,
+        nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_Directly,
         anyUFM, allUFM, seqEltsUFM,
         mapUFM, mapUFM_Directly,
         elemUFM, elemUFM_Directly,
@@ -324,8 +324,8 @@ nonDetStrictFoldUFM k z (UFM m) = M.foldl' (flip k) z m
 -- See Note [Deterministic UniqFM] to learn about nondeterminism.
 -- If you use this please provide a justification why it doesn't introduce
 -- nondeterminism.
-nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
-nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m
+nonDetStrictFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+nonDetStrictFoldUFM_Directly k z (UFM m) = M.foldlWithKey' (\z' i x -> k (getUnique i) x z') z m
 
 -- See Note [Deterministic UniqFM] to learn about nondeterminism.
 -- If you use this please provide a justification why it doesn't introduce



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe485655061199c09f1a81239738de74811fab36
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/20200402/2704da3f/attachment-0001.html>