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