Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/cabf31d60abde97d2a16b386d55106fc1b10a2f6 >--------------------------------------------------------------- commit cabf31d60abde97d2a16b386d55106fc1b10a2f6 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Tue Mar 13 12:48:36 2012 +0000 When abstracting over variables in the supercompiler, abstract over dictionaries first >--------------------------------------------------------------- compiler/coreSyn/MkCore.lhs | 10 +++++--- .../supercompile/Supercompile/Drive/Process.hs | 22 ++++++++++++++++--- 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 53386fe..4fc234e 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -13,7 +13,7 @@ module MkCore ( mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreLams, mkWildCase, mkIfThenElse, mkWildValBinder, mkWildEvBinder, - sortQuantVars, castBottomExpr, + sortQuantVars, quantVarLe, castBottomExpr, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -105,9 +105,10 @@ infixl 4 `mkCoreApp`, `mkCoreApps` sortQuantVars :: [Var] -> [Var] -- Sort the variables (KindVars, TypeVars, and Ids) -- into order: Kind, then Type, then Id -sortQuantVars = sortLe le - where - v1 `le` v2 = case (is_tv v1, is_tv v2) of +sortQuantVars = sortLe quantVarLe + +quantVarLe :: Var -> Var -> Bool +v1 `quantVarLe` v2 = case (is_tv v1, is_tv v2) of (True, False) -> True (False, True) -> False (True, True) -> @@ -116,6 +117,7 @@ sortQuantVars = sortLe le (False, True) -> False _ -> v1 <= v2 -- Same family (False, False) -> v1 <= v2 + where is_tv v = isTyVar v is_kv v = isKindVar v diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index f7c7668..53712b0 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -48,7 +48,7 @@ import Supercompile.StaticFlags import Supercompile.Utilities hiding (Monad(..)) import Var (isId, isTyVar, varType, setVarType) -import Id (idType, zapFragileIdInfo, localiseId) +import Id (idType, zapFragileIdInfo, localiseId, isDictId) import MkId (voidArgId, realWorldPrimId, mkPrimOpId) import Type (isUnLiftedType, mkTyVarTy) import Coercion (isCoVar, mkCoVarCo, mkUnsafeCo, coVarKind) @@ -56,11 +56,11 @@ import TyCon (PrimRep(..)) import Type (eqType, mkFunTy, mkPiTypes, mkTyConApp, typePrimRep, splitTyConApp_maybe) import TysPrim import TysWiredIn (unitTy, unboxedPairDataCon, unboxedPairTyCon) -import MkCore (mkWildValBinder, sortQuantVars) +import MkCore (mkWildValBinder, quantVarLe) import PrimOp (PrimOp(MyThreadIdOp)) import Literal import VarEnv -import Util (fstOf3, thirdOf3) +import Util (fstOf3, thirdOf3, sortLe) import qualified Control.Monad as Monad import Data.Ord @@ -803,10 +803,24 @@ stateAbsVars mb_lvs state = (abstracted, ty) | otherwise = (AbsVar { absVarDead = True, absVarVar = voidArgId } : abstracted, realWorldStatePrimTy `mkFunTy` ty) - where vs_list = sortQuantVars (varSetElems (stateLambdaBounders state)) + where vs_list = sortLe absVarLe (varSetElems (stateLambdaBounders state)) ty = vs_list `mkPiTypes` stateType state + abstracted = map (\v -> AbsVar { absVarDead = maybe False (not . (v `elemVarSet`)) mb_lvs, absVarVar = v }) vs_list +-- Our custom ordering function ensures we get the following ordering: +-- 1. Kind variables +-- 2. Type variables +-- 3. Dictionary ids +-- 4. Other ids +-- +-- The reason we want to sort dictionary ids earlier is so that GHC's own Specialise +-- pass is able to specialise functions on them (it assumes they come after the type vars). +absVarLe :: Var -> Var -> Bool +absVarLe v1 v2 + | isId v1, isId v2 = isDictId v1 >= isDictId v2 + | otherwise = quantVarLe v1 v2 + -- | Free variables that are allowed to be in the output term even though they weren't in the input (in addition to h-function names) extraOutputFvs :: FreeVars _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
