[project @ 2000-07-23 10:53:11 by panne]

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

diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 81799e5..884d70b 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -21,9 +21,8 @@ import Type           ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN,
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta, applyTys,
                          mkForAllTys, boxedTypeKind
                        )
-import PprType          ( {- instance Outputable Type -} )
-import Subst           ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList,
-                         substId, substAndCloneId, substAndCloneIds, lookupIdSubst
+import Subst           ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList,
+                         substId, substAndCloneId, substAndCloneIds, lookupIdSubst, substInScope
                        ) 
 import Var             ( TyVar, mkSysTyVar, setVarUnique )
 import VarSet
@@ -34,7 +33,7 @@ import CoreUnfold     ( certainlyWillInline )
 import CoreFVs         ( exprFreeVars, exprsFreeVars )
 import CoreLint                ( beginPass, endPass )
 import PprCore         ( pprCoreRules )
-import Rules           ( addIdSpecialisations )
+import Rules           ( addIdSpecialisations, lookupRule )
 
 import UniqSupply      ( UniqSupply,
                          UniqSM, initUs_, thenUs, thenUs_, returnUs, getUniqueUs, 
@@ -42,7 +41,7 @@ import UniqSupply     ( UniqSupply,
                        )
 import Name            ( nameOccName, mkSpecOcc, getSrcLoc )
 import FiniteMap
-import Maybes          ( MaybeErr(..), catMaybes )
+import Maybes          ( MaybeErr(..), catMaybes, maybeToBool )
 import ErrUtils                ( dumpIfSet )
 import Bag
 import List            ( partition )
@@ -595,9 +594,16 @@ specProgram us binds
 
        return binds'
   where
+       -- We need to start with a Subst that knows all the things
+       -- that are in scope, so that the substitution engine doesn't
+       -- accidentally re-use a unique that's already in use
+       -- Easiest thing is to do it all at once, as if all the top-level
+       -- decls were mutually recursive
+    top_subst      = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv
+
     go []          = returnSM ([], emptyUDs)
     go (bind:binds) = go binds                                 `thenSM` \ (binds', uds) ->
-                     specBind emptySubst bind uds      `thenSM` \ (bind', uds') ->
+                     specBind top_subst bind uds       `thenSM` \ (bind', uds') ->
                      returnSM (bind' ++ binds', uds')
 
 dump_specs var = pprCoreRules var (idSpecialisation var)
@@ -641,7 +647,7 @@ specExpr subst expr@(App fun arg)
                            returnSM (App fun' arg', uds_arg `plusUDs` uds_app)
 
     go (Var f)       args = case specVar subst f of
-                               Var f' -> returnSM (Var f', mkCallUDs f' args)
+                               Var f' -> returnSM (Var f', mkCallUDs subst f' args)
                                e'     -> returnSM (e', emptyUDs)       -- I don't expect this!
     go other        args = specExpr subst other
 
@@ -664,6 +670,7 @@ specExpr subst (Case scrut case_bndr alts)
     returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts)
   where
     (subst_alt, case_bndr') = substId subst case_bndr
+       -- No need to clone case binder; it can't float like a let(rec)
 
     spec_alt (con, args, rhs)
        = specExpr subst_rhs rhs                `thenSM` \ (rhs', uds) ->
@@ -813,10 +820,10 @@ specDefn subst calls (fn, rhs)
        -- It's role as a holder for a call instance is o'er
        -- But it might be alive for some other reason by now.
 
-    fn_type             = idType fn
-    (tyvars, theta, tau) = splitSigmaTy fn_type
-    n_tyvars            = length tyvars
-    n_dicts             = length theta
+    fn_type           = idType fn
+    (tyvars, theta, _) = splitSigmaTy fn_type
+    n_tyvars          = length tyvars
+    n_dicts           = length theta
 
     (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs
     rhs_dicts = take n_dicts rhs_ids
@@ -935,8 +942,8 @@ type CallInfo     = FiniteMap [Maybe Type]                  -- Nothing => unconstrained type ar
 unionCalls :: CallDetails -> CallDetails -> CallDetails
 unionCalls c1 c2 = plusFM_C plusFM c1 c2
 
-singleCall :: (Id, [Maybe Type], [DictExpr]) -> CallDetails
-singleCall (id, tys, dicts) 
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> CallDetails
+singleCall id tys dicts 
   = unitFM id (unitFM tys (dicts, call_fvs))
   where
     call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
@@ -962,21 +969,26 @@ callDetailsToList calls = [ (id,tys,dicts)
                            (tys,dicts) <- fmToList fm
                          ]
 
-mkCallUDs f args 
+mkCallUDs subst f args 
   | null theta
   || length spec_tys /= n_tyvars
   || length dicts    /= n_dicts
-  = emptyUDs   -- Not overloaded
+  || maybeToBool (lookupRule (substInScope subst) f args)
+       -- There's already a rule covering this call.  A typical case
+       -- is where there's an explicit user-provided rule.  Then
+       -- we don't want to create a specialised version 
+       -- of the function that overlaps.
+  = emptyUDs   -- Not overloaded, or no specialisation wanted
 
   | otherwise
   = MkUD {dict_binds = emptyBag, 
-         calls      = singleCall (f, spec_tys, dicts)
+         calls      = singleCall f spec_tys dicts
     }
   where
-    (tyvars, theta, tau) = splitSigmaTy (idType f)
-    constrained_tyvars   = tyVarsOfTheta theta 
-    n_tyvars            = length tyvars
-    n_dicts             = length theta
+    (tyvars, theta, _) = splitSigmaTy (idType f)
+    constrained_tyvars = tyVarsOfTheta theta 
+    n_tyvars          = length tyvars
+    n_dicts           = length theta
 
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]