[project @ 1998-04-30 18:47:08 by sof]

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

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 04cd693..a1c602d 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -4,10 +4,7 @@
 \section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
 
 \begin{code}
-module Specialise (
-       specProgram, 
-       idSpecVars
-    ) where
+module Specialise ( specProgram ) where
 
 #include "HsVersions.h"
 
@@ -26,7 +23,7 @@ import Type           ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
                          tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
                        )
 import TyCon           ( TyCon )
-import TyVar           ( TyVar, mkTyVar,
+import TyVar           ( TyVar, mkTyVar, mkSysTyVar,
                          TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
                                    elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
                                    minusTyVarSet,
@@ -34,8 +31,9 @@ import TyVar          ( TyVar, mkTyVar,
                        )
 import Kind            ( mkBoxedTypeKind )
 import CoreSyn
+import FreeVars                ( exprFreeVars )
 import PprCore         ()      -- Instances 
-import Name            ( NamedThing(..), getSrcLoc, mkSysLocalName )
+import Name            ( NamedThing(..), getSrcLoc, mkSysLocalName, isLocallyDefined )
 import SrcLoc          ( noSrcLoc )
 import SpecEnv         ( addToSpecEnv, lookupSpecEnv, specEnvValues )
 
@@ -44,7 +42,7 @@ import UniqSupply     ( UniqSupply,
                        )
 import Unique          ( mkAlphaTyVarUnique )
 import FiniteMap
-import Maybes          ( MaybeErr(..), maybeToBool )
+import Maybes          ( MaybeErr(..), maybeToBool, catMaybes )
 import Bag
 import List            ( partition )
 import Util            ( zipEqual )
@@ -792,10 +790,6 @@ specDefn calls (fn, rhs)
     (tyvars, theta, tau) = splitSigmaTy fn_type
     n_tyvars            = length tyvars
     n_dicts             = length theta
-    mk_spec_tys call_ts  = zipWith mk_spec_ty call_ts tyVarTemplates
-                         where
-                           mk_spec_ty (Just ty) _     = ty
-                           mk_spec_ty Nothing   tyvar = mkTyVarTy tyvar
 
     (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs
     rhs_dicts = take n_dicts rhs_ids
@@ -825,8 +819,14 @@ specDefn calls (fn, rhs)
                --      f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
                -- and the type of this binder
         let
-           spec_tyvars = [tyvar | (tyvar, Nothing) <- tyVarTemplates `zip` call_ts]
-          spec_tys    = mk_spec_tys call_ts
+         mk_spec_ty Nothing   = newTyVarSM   `thenSM` \ tyvar ->
+                                returnSM (Just tyvar, mkTyVarTy tyvar)
+         mk_spec_ty (Just ty) = returnSM (Nothing,    ty)
+        in
+        mapSM mk_spec_ty call_ts   `thenSM` \ stuff ->
+        let
+          (maybe_spec_tyvars, spec_tys) = unzip stuff
+           spec_tyvars = catMaybes maybe_spec_tyvars
           spec_rhs    = mkTyLam spec_tyvars $
                          mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
           spec_id_ty  = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
@@ -1080,45 +1080,13 @@ specUDs tv_env_list dict_env_list (dbs, calls)
 %************************************************************************
 
 \begin{code}
-tyVarTemplates :: [TyVar]
-tyVarTemplates = map mk [1..]
-  where
-    mk i = mkTyVar (mkSysLocalName uniq occ noSrcLoc) mkBoxedTypeKind
-        where
-          uniq = mkAlphaTyVarUnique i
-          occ  = _PK_ ("$t" ++ show i)
-\end{code}
-
-\begin{code}
 lookupId:: IdEnv Id -> Id -> Id
 lookupId env id = case lookupIdEnv env id of
                        Nothing  -> id
                        Just id' -> id'
 
 dictRhsFVs :: CoreExpr -> IdSet
-       -- Cheapo function for simple RHSs
-dictRhsFVs e
-  = go e
-  where
-    go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
-    go (App e1 (LitArg l)) = go e1
-    go (App e1 (TyArg t))  = go e1
-    go (Var v)            = unitIdSet v
-    go (Lit l)            = emptyIdSet
-    go (Con _ args)        = mkIdSet [id | VarArg id <- args]
-    go (Note _ e)         = go e
-
-    go (Case e _)         = go e       -- Claim: no free dictionaries in the alternatives
-                                       -- These case expressions are of the form
-                                       --   case d of { D a b c -> b }
-
-    go (Lam _ _)          = emptyIdSet -- This can happen for a Functor "dict",
-                                       -- which is represented by the function
-                                       -- itself; but it won't have any further
-                                       -- dicts inside it.  I hope.
-
-    go other              = pprPanic "dictRhsFVs" (ppr e)
-
+dictRhsFVs e = exprFreeVars isLocallyDefined e
 
 addIdSpecialisations id spec_stuff
   = (if not (null errs) then
@@ -1134,22 +1102,6 @@ addIdSpecialisations id spec_stuff
                Succeeded spec_env' -> (spec_env', errs)
                Failed err          -> (spec_env, err:errs)
 
--- Given an Id, isSpecVars returns all its specialisations.
--- We extract these from its SpecEnv.
--- This is used by the occurrence analyser and free-var finder;
--- we regard an Id's specialisations as free in the Id's definition.
-
-idSpecVars :: Id -> [Id]
-idSpecVars id 
-  = map get_spec (specEnvValues (getIdSpecialisation id))
-  where
-    -- get_spec is another cheapo function like dictRhsFVs
-    -- It knows what these specialisation temlates look like,
-    -- and just goes for the jugular
-    get_spec (App f _) = get_spec f
-    get_spec (Lam _ b) = get_spec b
-    get_spec (Var v)   = v
-
 ----------------------------------------
 type SpecM a = UniqSM a
 
@@ -1171,6 +1123,10 @@ newIdSM old_id new_ty
                          new_ty
                          (getSrcLoc old_id)
     )
+
+newTyVarSM
+  = getUnique          `thenSM` \ uniq ->
+    returnSM (mkSysTyVar uniq mkBoxedTypeKind)
 \end{code}