[project @ 2001-02-28 11:48:34 by simonpj]
[ghc-hetmet.git] / ghc / compiler / specialise / Specialise.lhs
index 272fa27..bdef352 100644 (file)
@@ -8,44 +8,42 @@ module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlags, DynFlag(..), dopt )
-import Id              ( Id, idName, idType, mkTemplateLocals, mkUserLocal,
-                         idSpecialisation, setIdNoDiscard, isExportedId,
-                         modifyIdInfo, idUnfolding
+import CmdLineOpts     ( DynFlags, DynFlag(..) )
+import Id              ( Id, idName, idType, mkUserLocal,
+                         idSpecialisation, modifyIdInfo
                        )
 import IdInfo          ( zapSpecPragInfo )
 import VarSet
 import VarEnv
 
-import Type            ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
-                         tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
-                         mkForAllTys, boxedTypeKind
+import Type            ( Type, mkTyVarTy, splitSigmaTy, 
+                         tyVarsOfTypes, tyVarsOfTheta, 
+                         mkForAllTys 
                        )
 import Subst           ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, mkInScopeSet,
                          substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
                        ) 
-import Var             ( TyVar, mkSysTyVar, setVarUnique )
 import VarSet
 import VarEnv
 import CoreSyn
 import CoreUtils       ( applyTypeToArgs )
 import CoreUnfold      ( certainlyWillInline )
 import CoreFVs         ( exprFreeVars, exprsFreeVars )
-import CoreLint                ( beginPass, endPass )
+import CoreLint                ( showPass, endPass )
 import PprCore         ( pprCoreRules )
 import Rules           ( addIdSpecialisations, lookupRule )
 
 import UniqSupply      ( UniqSupply,
-                         UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, 
-                         getUs, setUs, uniqFromSupply, splitUniqSupply, mapUs
+                         UniqSM, initUs_, thenUs, thenUs, returnUs, getUniqueUs, 
+                         withUs, mapUs
                        )
 import Name            ( nameOccName, mkSpecOcc, getSrcLoc )
 import FiniteMap
-import Maybes          ( MaybeErr(..), catMaybes, maybeToBool )
+import Maybes          ( catMaybes, maybeToBool )
 import ErrUtils                ( dumpIfSet_dyn )
 import Bag
 import List            ( partition )
-import Util            ( zipEqual, zipWithEqual, mapAccumL )
+import Util            ( zipEqual, zipWithEqual )
 import Outputable
 
 
@@ -582,14 +580,12 @@ Hence, the invariant is this:
 specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
 specProgram dflags us binds
   = do
-       beginPass dflags "Specialise"
+       showPass dflags "Specialise"
 
        let binds' = initSM us (go binds        `thenSM` \ (binds', uds') ->
                                returnSM (dumpAllDictBinds uds' binds'))
 
-       endPass dflags "Specialise" 
-                       (dopt Opt_D_dump_spec dflags 
-                          || dopt Opt_D_verbose_core2core dflags) binds'
+       endPass dflags "Specialise" Opt_D_dump_spec binds'
 
        dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
                  (vcat (map dump_specs (concat (map bindersOf binds'))))
@@ -804,9 +800,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, 
@@ -839,10 +835,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
@@ -884,9 +880,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)
@@ -1097,11 +1094,8 @@ lookupId env id = case lookupVarEnv env id of
 type SpecM a = UniqSM a
 
 thenSM    = thenUs
-thenSM_    = thenUs_
 returnSM  = returnUs
 getUniqSM = getUniqueUs
-getUniqSupplySM = getUs
-setUniqSupplySM = setUs
 mapSM     = mapUs
 initSM   = initUs_
 
@@ -1114,44 +1108,34 @@ 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)
-  = getUs      `thenUs` \ us ->
+  = withUs     $ \ us ->
     let
        (subst', us', bndr') = substAndCloneId subst us bndr
     in
-    setUs us'  `thenUs_`
-    returnUs (subst, subst', NonRec bndr' rhs)
+    ((subst, subst', NonRec bndr' rhs), us')
 
 cloneBindSM subst (Rec pairs)
-  = getUs      `thenUs` \ us ->
+  = withUs     $ \ us ->
     let
        (subst', us', bndrs') = substAndCloneIds subst us (map fst pairs)
     in
-    setUs us'  `thenUs_`
-    returnUs (subst', subst', Rec (bndrs' `zip` map snd pairs))
+    ((subst', subst', Rec (bndrs' `zip` map snd pairs)), us')
 
 cloneBinders subst bndrs
-  = getUs      `thenUs` \ us ->
+  = withUs     $ \ us -> 
     let
        (subst', us', bndrs') = substAndCloneIds subst us bndrs
     in
-    setUs us'  `thenUs_`
-    returnUs (subst', bndrs')
-
+    ((subst', bndrs'), us')
 
 newIdSM old_id new_ty
   = getUniqSM          `thenSM` \ uniq ->
     let 
        -- Give the new Id a similar occurrence name to the old one
-       -- We used to add setIdNoDiscard if the old id was exported, to
-       -- avoid it being dropped as dead code, but that's not necessary any more.
        name   = idName old_id
        new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name)
     in
     returnSM new_id
-
-newTyVarSM
-  = getUniqSM          `thenSM` \ uniq ->
-    returnSM (mkSysTyVar uniq boxedTypeKind)
 \end{code}