[project @ 2001-08-24 12:45:28 by simonpj]

[ghc-hetmet.git] / ghc / compiler / specialise / SpecConstr.lhs

diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs
index 59fef91..7f2246a 100644 (file)
--- a/ghc/compiler/specialise/SpecConstr.lhs
+++ b/ghc/compiler/specialise/SpecConstr.lhs
@@ -16,7 +16,7 @@ import CoreUtils      ( exprType, eqExpr )
 import CoreFVs                 ( exprsFreeVars )
 import DataCon         ( dataConRepArity )
 import Type            ( tyConAppArgs )
-import PprCore         ( pprCoreRules )
+import PprCore         ( pprCoreRules, pprCoreRule )
 import Id              ( Id, idName, idType, idSpecialisation,
                          isDataConId_maybe,
                          mkUserLocal, mkSysLocal )
@@ -35,6 +35,7 @@ import Util           ( mapAccumL )
 import List            ( nubBy, partition )
 import UniqSupply
 import Outputable
+import UniqFM          ( ufmToList )
 \end{code}
 
 -----------------------------------------------------
@@ -222,6 +223,11 @@ data HowBound = RecFun             -- These are the recursive functions for which
                                -- passed as a parameter and what is in scope at the 
                                -- function definition site
 
+instance Outputable HowBound where
+  ppr RecFun = text "RecFun"
+  ppr RecArg = text "RecArg"
+  ppr Other = text "Other"
+
 lookupScopeEnv env v = lookupVarEnv (scope env) v
 
 extendBndrs env bndrs = env { scope = extendVarEnvList (scope env) [(b,Other) | b <- bndrs] }
@@ -370,18 +376,20 @@ scExpr env e@(App _ _)
 scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 scBind env (Rec [(fn,rhs)])
   | not (null val_bndrs)
-  = scExpr env' body                   `thenUs` \ (usg, body') ->
+  = scExpr env_fn_body body            `thenUs` \ (usg, body') ->
     let
        SCU { calls = calls, occs = occs } = usg
     in
     specialise env fn bndrs body usg   `thenUs` \ (rules, spec_prs) ->
-    returnUs (extendBndrs env bndrs,
+    returnUs (extendBndr env fn,       -- For the body of the letrec, just
+                                       -- extend the env with Other to record 
+                                       -- that it's in scope; no funny RecFun business
              SCU { calls = calls `delVarEnv` fn, occs = occs `delVarEnvList` val_bndrs},
              Rec ((fn `addIdSpecialisations` rules, mkLams bndrs body') : spec_prs))
   where
     (bndrs,body) = collectBinders rhs
     val_bndrs    = filter isId bndrs
-    env'        = extendRecBndr env fn bndrs
+    env_fn_body         = extendRecBndr env fn bndrs
 
 scBind env (Rec prs)
   = mapAndUnzipUs do_one prs   `thenUs` \ (usgs, prs') ->
@@ -430,7 +438,6 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
                       let (_, pats) = argsToPats con_env us call_args
                     ]
     in
-    pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $
     mapAndUnzipUs (spec_one env fn (mkLams bndrs body)) 
                  (nubBy same_call good_calls `zip` [1..])
   where
@@ -446,8 +453,7 @@ good_arg con_env arg_occs (bndr, arg)
 
 bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
 bndr_usg_ok arg_occs bndr arg
-  = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $
-    case lookupVarEnv arg_occs bndr of
+  = case lookupVarEnv arg_occs bndr of
        Just CaseScrut -> True                  -- Used only by case scrutiny
        Just Both      -> case arg of           -- Used by case and elsewhere
                            App _ _ -> True     -- so the arg should be an explicit con app
@@ -470,18 +476,17 @@ spec_one :: ScEnv
   Example
   
      In-scope: a, x::a   
-     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) v (h v))...
-         [c is presumably bound by the (...) part]
+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
+         [c::*, v::(b,c) are presumably bound by the (...) part]
   ==>
-     f_spec = /\ b c \ v::(a,(b,c)) -> 
-                 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) v (h v))
+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
+                 (...entire RHS of f...) (b,c) ((:) (a,(b,c)) (x,v) hw)
   
-     RULE:  forall b c,
-                  y::[(a,(b,c))], 
-                  v::(a,(b,c)), 
-                  h::(a,(b,c))->[(a,(b,c))] .
+     RULE:  forall b::* c::*,          -- Note, *not* forall a, x
+                  v::(b,c),
+                  hw::[(a,(b,c))] .
   
-           f (b,c) ((:) (a,(b,c)) v (h v)) = f_spec b c v
+           f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
 -}
 
 spec_one env fn rhs (pats, n)
@@ -493,14 +498,15 @@ spec_one env fn rhs (pats, n)
        pat_fvs      = varSetElems (exprsFreeVars pats)
        vars_to_bind = filter not_avail pat_fvs
        not_avail v  = not (v `elemVarEnv` scope env)
-               -- Put the type variables first just for tidiness
+               -- Put the type variables first; the type of a term
+               -- variable may mention a type variable
        (tvs, ids)   = partition isTyVar vars_to_bind
        bndrs        = tvs ++ ids
        
        rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n))
        spec_rhs  = mkLams bndrs (mkApps rhs pats)
        spec_id   = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
-       rule      = Rule rule_name pat_fvs pats (mkVarApps (Var spec_id) bndrs)
+       rule      = Rule rule_name bndrs pats (mkVarApps (Var spec_id) bndrs)
     in
     returnUs (rule, (spec_id, spec_rhs))
 \end{code}