[commit: ghc] supercompiler: When abstracting over variables in the supercompiler, abstract over dictionaries first (cabf31d)

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

On branch  : supercompiler

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

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

commit cabf31d60abde97d2a16b386d55106fc1b10a2f6
Author: Max Bolingbroke <[email protected]>
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