[project @ 2001-05-03 08:13:25 by simonpj]

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

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 6fbc5b9..da60b7f 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -12,17 +12,16 @@ import CmdLineOpts  ( DynFlags, DynFlag(..) )
 import Id              ( Id, idName, idType, mkUserLocal,
                          idSpecialisation, modifyIdInfo
                        )
-import IdInfo          ( zapSpecPragInfo )
-import VarSet
-import VarEnv
-
 import Type            ( Type, mkTyVarTy, splitSigmaTy, 
                          tyVarsOfTypes, tyVarsOfTheta, 
                          mkForAllTys 
                        )
-import Subst           ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
-                         substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
+import Subst           ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
+                         simplBndr, simplBndrs, 
+                         substAndCloneId, substAndCloneIds, substAndCloneRecIds,
+                         lookupIdSubst, substInScope
                        ) 
+import Var             ( zapSpecPragmaId )
 import VarSet
 import VarEnv
 import CoreSyn
@@ -34,8 +33,8 @@ import PprCore                ( pprCoreRules )
 import Rules           ( addIdSpecialisations, lookupRule )
 
 import UniqSupply      ( UniqSupply,
-                         UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, 
-                         withUs, mapUs
+                         UniqSM, initUs_, thenUs, returnUs, getUniqueUs, 
+                         getUs, mapUs
                        )
 import Name            ( nameOccName, mkSpecOcc, getSrcLoc )
 import FiniteMap
@@ -658,7 +657,7 @@ specExpr subst e@(Lam _ _)
     returnSM (mkLams bndrs' body'', filtered_uds)
   where
     (bndrs, body) = collectBinders e
-    (subst', bndrs') = substBndrs subst bndrs
+    (subst', bndrs') = simplBndrs subst bndrs
        -- More efficient to collect a group of binders together all at once
        -- and we don't want to split a lambda group with dumped bindings
 
@@ -667,7 +666,7 @@ specExpr subst (Case scrut case_bndr alts)
     mapAndCombineSM spec_alt alts      `thenSM` \ (alts', uds_alts) ->
     returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
   where
-    (subst_alt, case_bndr') = substId subst case_bndr
+    (subst_alt, case_bndr') = simplBndr subst case_bndr
        -- No need to clone case binder; it can't float like a let(rec)
 
     spec_alt (con, args, rhs)
@@ -677,7 +676,7 @@ specExpr subst (Case scrut case_bndr alts)
          in
          returnSM ((con, args', rhs''), uds')
        where
-         (subst_rhs, args') = substBndrs subst_alt args
+         (subst_rhs, args') = simplBndrs subst_alt args
 
 ---------------- Finally, let is the interesting case --------------------
 specExpr subst (Let bind body)
@@ -800,9 +799,9 @@ specDefn subst calls (fn, rhs)
       -- Make a specialised version for each call in calls_for_me
     mapSM spec_call calls_for_me               `thenSM` \ stuff ->
     let
-       (spec_defns, spec_uds, spec_env_stuff) = unzip3 stuff
+       (spec_defns, spec_uds, spec_rules) = unzip3 stuff
 
-       fn' = addIdSpecialisations zapped_fn spec_env_stuff
+       fn' = addIdSpecialisations zapped_fn spec_rules
     in
     returnSM ((fn',rhs'), 
              spec_defns, 
@@ -813,7 +812,7 @@ specDefn subst calls (fn, rhs)
     returnSM ((zapped_fn, rhs'), [], rhs_uds)
   
   where
-    zapped_fn           = modifyIdInfo zapSpecPragInfo fn
+    zapped_fn           = zapSpecPragmaId fn
        -- If the fn is a SpecPragmaId, make it discardable
        -- It's role as a holder for a call instance is o'er
        -- But it might be alive for some other reason by now.
@@ -835,10 +834,10 @@ specDefn subst calls (fn, rhs)
 
     ----------------------------------------------------------
        -- Specialise to one particular call pattern
-    spec_call :: ([Maybe Type], ([DictExpr], VarSet))          -- Call instance
-              -> SpecM ((Id,CoreExpr),                         -- Specialised definition
-                       UsageDetails,                           -- Usage details from specialised body
-                       ([CoreBndr], [CoreExpr], CoreExpr))     -- Info for the Id's SpecEnv
+    spec_call :: ([Maybe Type], ([DictExpr], VarSet))  -- Call instance
+              -> SpecM ((Id,CoreExpr),                 -- Specialised definition
+                       UsageDetails,                   -- Usage details from specialised body
+                       CoreRule)                       -- Info for the Id's SpecEnv
     spec_call (call_ts, (call_ds, call_fvs))
       = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
                -- Calls are only recorded for properly-saturated applications
@@ -880,9 +879,10 @@ specDefn subst calls (fn, rhs)
        let
                -- The rule to put in the function's specialisation is:
                --      forall b,d, d1',d2'.  f t1 b t3 d d1' d2' = f1 b d  
-           spec_env_rule = (poly_tyvars ++ rhs_dicts',
-                           inst_args, 
-                           mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
+           spec_env_rule = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+                               (poly_tyvars ++ rhs_dicts')
+                               inst_args 
+                               (mkTyApps (Var spec_f) (map mkTyVarTy poly_tyvars))
 
                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
           final_uds = foldr addDictBind rhs_uds (my_zipEqual "spec_call" rhs_dicts' call_ds)
@@ -1107,25 +1107,22 @@ cloneBindSM :: Subst -> CoreBind -> SpecM (Subst, Subst, CoreBind)
 -- Clone the binders of the bind; return new bind with the cloned binders
 -- Return the substitution to use for RHSs, and the one to use for the body
 cloneBindSM subst (NonRec bndr rhs)
-  = withUs     $ \ us ->
+  = getUs      `thenUs` \ us ->
     let
-       (subst', us', bndr') = substAndCloneId subst us bndr
+       (subst', bndr') = substAndCloneId subst us bndr
     in
-    ((subst, subst', NonRec bndr' rhs), us')
+    returnUs (subst, subst', NonRec bndr' rhs)
 
 cloneBindSM subst (Rec pairs)
-  = withUs     $ \ us ->
+  = getUs      `thenUs` \ us ->
     let
-       (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
+       (subst', bndrs') = substAndCloneRecIds subst us (map fst pairs)
     in
-    ((subst', subst', Rec (bndrs' `zip` map snd pairs)), us')
+    returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
 
 cloneBinders subst bndrs
-  = withUs     $ \ us -> 
-    let
-       (subst', us', bndrs') = substAndCloneIds subst us bndrs
-    in
-    ((subst', bndrs'), us')
+  = getUs      `thenUs` \ us ->
+    returnUs (substAndCloneIds subst us bndrs)
 
 newIdSM old_id new_ty
   = getUniqSM          `thenSM` \ uniq ->