[commit: ghc] : Must abstract over type varibles as well when refining fulfilment FVs (f71dfb7)

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

On branch  : 

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

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

commit f71dfb7e5e985c7a92a8a73a5e8d5637486dbbc7
Author: Max Bolingbroke <[email protected]>
Date:   Wed Jul 27 22:36:52 2011 +0100

    Must abstract over type varibles as well when refining fulfilment FVs

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

 .../supercompile/Supercompile/Core/FreeVars.hs     |    4 ++--
 .../supercompile/Supercompile/Drive/Process.hs     |   10 +++++++---
 2 files changed, 9 insertions(+), 5 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/FreeVars.hs b/compiler/supercompile/Supercompile/Core/FreeVars.hs
index edef8b7..6711c5f 100644
--- a/compiler/supercompile/Supercompile/Core/FreeVars.hs
+++ b/compiler/supercompile/Supercompile/Core/FreeVars.hs
@@ -3,7 +3,7 @@
 module Supercompile.Core.FreeVars (
     module Supercompile.Core.FreeVars,
     module VarSet,
-    tyVarsOfType, tyCoVarsOfCo
+    tyVarsOfType, tyVarsOfTypes, tyCoVarsOfCo
   ) where
 
 import Supercompile.Core.Syntax
@@ -17,7 +17,7 @@ import CoreFVs
 import VarSet
 import Coercion (tyCoVarsOfCo)
 import Var      (isTyVar)
-import Type     (tyVarsOfType)
+import Type     (tyVarsOfType, tyVarsOfTypes)
 
 
 type FreeVars = VarSet
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index f542560..5fcfba2 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -30,7 +30,7 @@ import Supercompile.StaticFlags
 import Supercompile.Utilities
 
 import Var        (isTyVar, varType)
-import Id         (mkLocalId)
+import Id         (idType, mkLocalId)
 import Name       (Name, mkSystemVarName)
 import FastString (mkFastString)
 import CoreUtils  (mkPiTypes)
@@ -428,13 +428,17 @@ promise p x' opt = ScpM $ \e s k -> {- traceRender ("promise", fun p, abstracted
       -- actually need. We aren't able to do anything about the stuff they spuriously allocate as a result, but we can make generate a little wrapper that just discards
       -- those arguments. With luck, GHC will inline it and good things will happen.
       --
+      -- We have to be careful when generating the wrapper: the *type variables* of the optimised_fvs must also be abstracted over!
+      --
       -- TODO: we can generate the wrappers in a smarter way now that we can always see all possible fulfilments?
-      let optimised_fvs = fvedTermFreeVars optimised_e
+      let optimised_fvs_incomplete = fvedTermFreeVars optimised_e
+          optimised_fvs = optimised_fvs_incomplete `unionVarSet` tyVarsOfTypes (map idType (varSetElems optimised_fvs_incomplete))
           abstracted_set = mkVarSet (abstracted p)
           abstracted'_set = optimised_fvs `intersectVarSet` abstracted_set -- We still don't want to abstract over e.g. phantom bindings
           abstracted'_list = sortLambdaBounds $ varSetElems abstracted'_set
           fun' = mkLocalId x' (abstracted'_list `mkPiTypes` stateType (unI (meaning p)))
-      ScpM $ \_e s k -> let fs' | abstracted_set == abstracted'_set || not rEFINE_FULFILMENT_FVS
+      pprTrace "promise" (ppr optimised_fvs $$ ppr optimised_e) $
+       ScpM $ \_e s k -> let fs' | abstracted_set == abstracted'_set || not rEFINE_FULFILMENT_FVS
                                  -- If the free variables are totally unchanged, there is nothing to be gained from clever fiddling
                                 = (P { fun = fun p, abstracted = abstracted p, meaning = Just (unI (meaning p)) }, tyVarIdLambdas (abstracted p) optimised_e) : fulfilments s
                                 | otherwise