[commit: ghc] supercompiler: Abstract all h-functions over RealWorld# (d6128ff)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/d6128ff233c679a9a6b1d3d5d2dc63b1f217a5cc

>---------------------------------------------------------------

commit d6128ff233c679a9a6b1d3d5d2dc63b1f217a5cc
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 3 15:04:39 2012 +0000

    Abstract all h-functions over RealWorld#

>---------------------------------------------------------------

 .../supercompile/Supercompile/Drive/Process.hs     |   23 ++++++++++++-------
 .../supercompile/Supercompile/Drive/Process1.hs    |    8 ++----
 .../supercompile/Supercompile/Drive/Process2.hs    |    7 ++---
 .../supercompile/Supercompile/Drive/Process3.hs    |    7 ++---
 4 files changed, 23 insertions(+), 22 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index f951d0e..76e7efd 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -43,13 +43,14 @@ import Supercompile.Termination.Generaliser
 import Supercompile.StaticFlags
 import Supercompile.Utilities hiding (Monad(..))
 
-import Name       (getOccString)
 import Var        (isId, isTyVar, varType, setVarType)
-import Id         (idType, idOccInfo, zapFragileIdInfo, setIdOccInfo, localiseId)
+import Id         (idType, zapFragileIdInfo, localiseId)
+import MkId       (voidArgId)
 import Type       (isUnLiftedType, mkTyVarTy)
 import Coercion   (isCoVar, mkCoVarCo, mkUnsafeCo, coVarKind_maybe, mkCoercionType)
+import CoreUtils  (mkPiTypes)
 import TyCon      (PrimRep(..))
-import Type       (typePrimRep, splitTyConApp_maybe)
+import Type       (mkFunTy, typePrimRep, splitTyConApp_maybe)
 import TysPrim
 import TysWiredIn (unitTy)
 import Literal
@@ -451,10 +452,6 @@ renameAbsVar rn (AbsVar { absVarDead = dead, absVarVar = x })
   | otherwise
   = AbsVar { absVarDead = False, absVarVar = renameAbsVarType rn (M.findWithDefault (pprPanic "renameAbsVar" (ppr x)) x rn) }
 
--- FIXME: should abstract over RealWorld# as well. Two reasons:
---  1. If the h-function is unlifted, this delays its evaluation (so its effects, if any, do not happen too early)
---  2. This expresses to GHC that we don't necessarily want the work in h-functions to be shared
-
 -- NB: it's important that we use localiseId on the absVarVar at binding sites, or else if we start
 -- with a state where a global Id is lambda-bound (because there is no unfolding) we might end up having an h-function
 -- that is lambda-abstracted over a global Id, which causes the assembler to barf.
@@ -532,8 +529,16 @@ applyAbsVars x xs = snd (foldl go (unitVarSet x, var x) xs)
                -- NB: make sure we zap the "fragile" info because the FVs of the unfolding are
                -- not necessarily in scope.
 
-stateAbsVars :: State -> [Var]
-stateAbsVars = sortLambdaBounds . varSetElems . stateLambdaBounders
+-- NB: we abstract over RealWorld# as well (cf WwLib). Two reasons:
+--  1. If the h-function is unlifted, this delays its evaluation (so its effects, if any, do not happen too early).
+--     This is also necessary since h-functions will be bound in one letrec after supercompilation is complete.
+--  2. This expresses to GHC that we don't necessarily want the work in h-functions to be shared.
+stateAbsVars :: Maybe FreeVars -> State -> ([AbsVar], Type)
+stateAbsVars mb_lvs state = (abstracted, realWorldStatePrimTy `mkFunTy` (vs_list `mkPiTypes` state_ty))
+  where vs_list = sortLambdaBounds (varSetElems (stateLambdaBounders state))
+        state_ty = stateType state
+        abstracted = AbsVar { absVarDead = True, absVarVar = voidArgId } :
+                     map (\v -> AbsVar { absVarDead = maybe False (not . (v `elemVarSet`)) mb_lvs, absVarVar = v }) vs_list
 
 sortLambdaBounds :: [Var] -> [Var]
 sortLambdaBounds = sortBy (comparing (not . isTyVar)) -- True type variables go first since coercion/value variables may reference them
diff --git a/compiler/supercompile/Supercompile/Drive/Process1.hs b/compiler/supercompile/Supercompile/Drive/Process1.hs
index 060acbb..4555b14 100644
--- a/compiler/supercompile/Supercompile/Drive/Process1.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process1.hs
@@ -28,13 +28,11 @@ import Supercompile.Termination.Generaliser
 import Supercompile.StaticFlags
 import Supercompile.Utilities hiding (Monad(..))
 
-import Id         (mkLocalId, setIdOccInfo)
+import Id         (mkLocalId)
 import Name       (Name, mkSystemVarName)
 import FastString (mkFastString)
-import CoreUtils  (mkPiTypes)
 import qualified State as State
 import State hiding (State, mapAccumLM)
-import BasicTypes (OccInfo(..))
 
 import Text.XHtml hiding (text)
 
@@ -480,11 +478,11 @@ memo opt speculated state0 = do
         traceRenderScpM "=sc" (fun p, PrettyDoc (pPrintFullState fullStatePrettiness state1), res)
         ScpM $ \_ s k -> k res (s { pTreeHole = Tieback (fun p) })
       [] -> {- traceRender ("new drive", pPrintFullState state3) $ -} do
-        let vs_list = stateAbsVars state1
+        let (vs_list, h_ty) = stateAbsVars Nothing state1
 
         -- NB: promises are lexically scoped because they may refer to FVs
         x <- freshHName
-        promise (P { fun = mkLocalId x (vs_list `mkPiTypes` stateType state1), abstracted = map mkLiveAbsVar vs_list, meaning = state1, embedded = Nothing }) $
+        promise (P { fun = mkLocalId x h_ty, abstracted = vs_list, meaning = state1, embedded = Nothing }) $
           do
             traceRenderScpM ">sc" (x, PrettyDoc (pPrintFullState fullStatePrettiness state1))
             -- FIXME: this is the site of the Dreadful Hack that makes it safe to match on reduced terms yet *drive* unreduced ones
diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs
index 95780cf..46244a2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process2.hs
@@ -22,7 +22,6 @@ import Supercompile.Utilities
 import Id         (mkLocalId)
 import Name       (Name, mkSystemVarName)
 import FastString (mkFastString)
-import CoreUtils  (mkPiTypes)
 import qualified State as State
 
 import qualified Data.Map as M
@@ -228,12 +227,12 @@ runFulfilmentT mx = liftM (\(e, fs) -> letRec (M.toList (fulfilments fs)) e) $ u
 
 promise :: State -> MemoState -> (Promise, MemoState)
 promise state ms = (p, ms')
-  where vs_list = stateAbsVars state
+  where (vs_list, h_ty) = stateAbsVars Nothing state
         h_name :< h_names' = hNames ms
-        x = mkLocalId h_name (vs_list `mkPiTypes` stateType state)
+        x = mkLocalId h_name h_ty
         p = P {
             fun        = x,
-            abstracted = map mkLiveAbsVar vs_list,
+            abstracted = vs_list,
             meaning    = state
           }
         ms' = MS {
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 0425c17..7758e77 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -25,7 +25,6 @@ import Var        (varName)
 import Id         (mkLocalId)
 import Name       (Name, mkSystemVarName, getOccString)
 import FastString (mkFastString)
-import CoreUtils  (mkPiTypes)
 
 import Control.Monad (join)
 
@@ -66,9 +65,9 @@ data MemoState = MS {
 
 promise :: (State, State) -> MemoState -> (Promise, MemoState)
 promise (state, reduced_state) ms = (p, ms')
-  where vs_list = stateAbsVars state
+  where (vs_list, h_ty) = stateAbsVars (Just (stateLambdaBounders reduced_state)) state
         h_name :< h_names' = hNames ms
-        x = mkLocalId h_name (vs_list `mkPiTypes` stateType state)
+        x = mkLocalId h_name h_ty
         p = P {
             fun        = x,
             -- We mark as dead any of those variables that are not in the stateLambdaBounders of
@@ -79,7 +78,7 @@ promise (state, reduced_state) ms = (p, ms')
             --   2. We can get rid of the code in renameAbsVar that downgrades live AbsVars to dead
             --      ones if they are not present in the renaming: only dead AbsVars are allowed to
             --      be absent in the renaming.
-            abstracted = map (\v -> AbsVar { absVarDead = not (v `elemVarSet` stateLambdaBounders reduced_state), absVarVar = v }) vs_list,
+            abstracted = vs_list,
             meaning    = reduced_state
           }
         ms' = MS {