Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/f71dfb7e5e985c7a92a8a73a5e8d5637486dbbc7 >--------------------------------------------------------------- commit f71dfb7e5e985c7a92a8a73a5e8d5637486dbbc7 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
