[Git][ghc/ghc][wip/with2-primop] 2 commits: CorePrep: Admit nested runRW# applications

[Ben Gamari]

Ben Gamari pushed to branch wip/with2-primop at Glasgow Haskell Compiler / GHC


Commits:
4fd166ae by Ben Gamari at 2020-04-19T04:50:47+00:00
CorePrep: Admit nested runRW# applications

We can then end up with applications of the form

    runRW# (\s s' -> ...) s''

Which have a higher apparent arity than CorePrep previously expected for
runRW#.

TODO: Do same for keepAlive#

- - - - -
88a9a43b by Ben Gamari at 2020-04-19T15:09:24+00:00
SetLevels: Don't float out of runRW# and keepAlive# apps

- - - - -


2 changed files:

- compiler/GHC/Core/Op/SetLevels.hs
- compiler/GHC/CoreToStg/Prep.hs


Changes:

=====================================
compiler/GHC/Core/Op/SetLevels.hs
=====================================
@@ -91,10 +91,12 @@ import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig,
 import GHC.Types.Cpr          ( mkCprSig, botCpr )
 import GHC.Types.Name         ( getOccName, mkSystemVarName )
 import GHC.Types.Name.Occurrence ( occNameString )
+import GHC.Types.Unique       ( hasKey )
 import GHC.Core.Type    ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
                         , mightBeUnliftedType, closeOverKindsDSet )
 import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )
 import GHC.Core.DataCon ( dataConOrigResTy )
+import PrelNames              ( runRWKey, keepAliveIdKey )
 import TysWiredIn
 import GHC.Types.Unique.Supply
 import Util
@@ -399,8 +401,12 @@ lvlNonTailExpr env expr
 lvlApp :: LevelEnv
        -> CoreExprWithFVs
        -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
-        -> LvlM LevelledExpr                   -- Result expression
+       -> LvlM LevelledExpr                    -- Result expression
 lvlApp env orig_expr ((_,AnnVar fn), args)
+  | fn `hasKey` runRWKey || fn `hasKey` keepAliveIdKey
+  = do { args' <- mapM (lvlExpr env) args
+       ; return (foldl' App (lookupVar env fn) args') }
+
   | floatOverSat env   -- See Note [Floating over-saturated applications]
   , arity > 0
   , arity < n_val_args


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -847,14 +847,18 @@ cpeApp top_env expr
         -- rather than the far superior "f x y".  Test case is par01.
         = let (terminal, args', depth') = collect_args arg
           in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
-    cpe_app env (Var f) [CpeApp _runtimeRep at Type{}, CpeApp _type at Type{}, CpeApp arg] 1
+    cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) n
         | f `hasKey` runRWKey
+        -- N.B. While it may appear that n == 1 in the case of runRW#
+        -- applications, keep in mind that we may have applications that return
+        , n >= 1
         -- See Note [runRW magic]
         -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
         -- is why we return a CorePrepEnv as well)
         = case arg of
-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
-            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2)
+            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1)
+             -- TODO: What about casts?
 
     cpe_app env (Var f) args n
         | f `hasKey` runRWKey



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae6dae6a6c4d668c2639764bee1e0bbf42c646d1...88a9a43b6a9d5c17f239fd13e72aa01937d7fade

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ae6dae6a6c4d668c2639764bee1e0bbf42c646d1...88a9a43b6a9d5c17f239fd13e72aa01937d7fade
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/20200419/58d2d725/attachment-0001.html>