[project @ 2001-11-01 13:20:05 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / SetLevels.lhs

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index e128eea..6cd9efb 100644 (file)
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -54,7 +54,7 @@ module SetLevels (
 
 import CoreSyn
 
-import CoreUtils       ( exprType, exprIsTrivial, exprIsBottom, mkPiType )
+import CoreUtils       ( exprType, exprIsTrivial, exprIsBottom, mkPiTypes )
 import CoreFVs         -- all of it
 import Subst
 import Id              ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo,
@@ -443,7 +443,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs)
                                                (mkVarApps (Var new_bndr) lam_bndrs))],
               poly_env)
 
-  | otherwise
+  | otherwise  -- Non-null abs_vars
   = newPolyBndrs dest_lvl env abs_vars bndrs           `thenLvl` \ (new_env, new_bndrs) ->
     mapLvl (lvlFloatRhs abs_vars dest_lvl new_env) rhss `thenLvl` \ new_rhss ->
     returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env)
@@ -510,25 +510,6 @@ lvlLamBndrs lvl bndrs
 \end{code}
 
 \begin{code}
-abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
-       -- Find the variables in fvs, free vars of the target expresion,
-       -- whose level is less than than the supplied level
-       -- These are the ones we are going to abstract out
-abstractVars dest_lvl env fvs
-  = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
-  where
-       -- Sort the variables so we don't get 
-       -- mixed-up tyvars and Ids; it's just messy
-    v1 `lt` v2 = case (isId v1, isId v2) of
-                  (True, False) -> False
-                  (False, True) -> True
-                  other         -> v1 < v2     -- Same family
-    uniq :: [Var] -> [Var]
-       -- Remove adjacent duplicates; the sort will have brought them together
-    uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
-                   | otherwise = v1 : uniq (v2:vs)
-    uniq vs = vs
-
   -- Destintion level is the max Id level of the expression
   -- (We'll abstract the type variables, if any.)
 destLevel :: LevelEnv -> VarSet -> Bool -> Level
@@ -674,13 +655,33 @@ lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
                                       Just (_, expr) -> expr
                                       other          -> Var v
 
+abstractVars :: Level -> LevelEnv -> VarSet -> [Var]
+       -- Find the variables in fvs, free vars of the target expresion,
+       -- whose level is greater than the destination level
+       -- These are the ones we are going to abstract out
+abstractVars dest_lvl env fvs
+  = uniq (sortLt lt [var | fv <- varSetElems fvs, var <- absVarsOf dest_lvl env fv])
+  where
+       -- Sort the variables so we don't get 
+       -- mixed-up tyvars and Ids; it's just messy
+    v1 `lt` v2 = case (isId v1, isId v2) of
+                  (True, False) -> False
+                  (False, True) -> True
+                  other         -> v1 < v2     -- Same family
+
+    uniq :: [Var] -> [Var]
+       -- Remove adjacent duplicates; the sort will have brought them together
+    uniq (v1:v2:vs) | v1 == v2  = uniq (v2:vs)
+                   | otherwise = v1 : uniq (v2:vs)
+    uniq vs = vs
+
 absVarsOf :: Level -> LevelEnv -> Var -> [Var]
-       -- If f is free in the exression, and f maps to poly_f a b c in the
+       -- If f is free in the expression, and f maps to poly_f a b c in the
        -- current substitution, then we must report a b c as candidate type
        -- variables
 absVarsOf dest_lvl (_, lvl_env, _, id_env) v 
   | isId v
-  = [final_av | av <- lookup_avs v, abstract_me av, final_av <- add_tyvars av]
+  = [zap av2 | av1 <- lookup_avs v, av2 <- add_tyvars av1, abstract_me av2]
 
   | otherwise
   = if abstract_me v then [v] else []
@@ -694,15 +695,16 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v
                        Just (abs_vars, _) -> abs_vars
                        Nothing            -> [v]
 
-       -- We are going to lambda-abstract, so nuke any IdInfo,
-       -- and add the tyvars of the Id
-    add_tyvars v | isId v    =  zap v  : varSetElems (idFreeTyVars v)
+    add_tyvars v | isId v    = v : varSetElems (idFreeTyVars v)
                 | otherwise = [v]
 
-    zap v = WARN( workerExists (idWorkerInfo v)
-                 || not (isEmptyCoreRules (idSpecialisation v)),
-                 text "absVarsOf: discarding info on" <+> ppr v )
-           setIdInfo v vanillaIdInfo
+       -- We are going to lambda-abstract, so nuke any IdInfo,
+       -- and add the tyvars of the Id (if necessary)
+    zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
+                          not (isEmptyCoreRules (idSpecialisation v)),
+                          text "absVarsOf: discarding info on" <+> ppr v )
+                    setIdInfo v vanillaIdInfo
+         | otherwise = v
 \end{code}
 
 \begin{code}
@@ -716,7 +718,7 @@ mapLvl              = mapUs
 
 \begin{code}
 newPolyBndrs dest_lvl env abs_vars bndrs
-  = getUniquesUs (length bndrs)                `thenLvl` \ uniqs ->
+  = getUniquesUs               `thenLvl` \ uniqs ->
     let
        new_bndrs = zipWith mk_poly_bndr bndrs uniqs
     in
@@ -725,7 +727,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs
     mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty
                           where
                             str     = "poly_" ++ occNameUserString (getOccName bndr)
-                            poly_ty = foldr mkPiType (idType bndr) abs_vars
+                            poly_ty = mkPiTypes abs_vars (idType bndr)
        
 
 newLvlVar :: String 
@@ -733,7 +735,7 @@ newLvlVar :: String
          -> LvlM Id
 newLvlVar str vars body_ty     
   = getUniqueUs        `thenLvl` \ uniq ->
-    returnUs (mkSysLocal (_PK_ str) uniq (foldr mkPiType body_ty vars))
+    returnUs (mkSysLocal (_PK_ str) uniq (mkPiTypes vars body_ty))
     
 -- The deeply tiresome thing is that we have to apply the substitution
 -- to the rules inside each Id.  Grr.  But it matters.