[project @ 2002-09-18 16:05:45 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 0428772..ae61e15 100644 (file)
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -9,9 +9,9 @@ module Specialise ( specProgram ) where
 #include "HsVersions.h"
 
 import CmdLineOpts     ( DynFlags, DynFlag(..) )
-import Id              ( Id, idName, idType, mkUserLocal, idSpecialisation, isDataConWrapId )
+import Id              ( Id, idName, idType, mkUserLocal, isDataConWrapId )
 import TcType          ( Type, mkTyVarTy, tcSplitSigmaTy, 
-                         tyVarsOfTypes, tyVarsOfTheta, 
+                         tyVarsOfTypes, tyVarsOfTheta, isClassPred,
                          mkForAllTys, tcCmpType
                        )
 import Subst           ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet,
@@ -25,8 +25,8 @@ import VarEnv
 import CoreSyn
 import CoreUtils       ( applyTypeToArgs )
 import CoreFVs         ( exprFreeVars, exprsFreeVars )
+import CoreTidy                ( pprTidyIdRules )
 import CoreLint                ( showPass, endPass )
-import PprCore         ( pprCoreRules )
 import Rules           ( addIdSpecialisations, lookupRule )
 
 import UniqSupply      ( UniqSupply,
@@ -40,9 +40,10 @@ import ErrUtils              ( dumpIfSet_dyn )
 import BasicTypes      ( Activation( AlwaysActive ) )
 import Bag
 import List            ( partition )
-import Util            ( zipEqual, zipWithEqual, cmpList )
+import Util            ( zipEqual, zipWithEqual, cmpList, lengthIs,
+                         equalLength, lengthAtLeast, notNull )
 import Outputable
-
+import FastString
 
 infixr 9 `thenSM`
 \end{code}
@@ -585,7 +586,7 @@ specProgram dflags us 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'))))
+                 (vcat (map pprTidyIdRules (concat (map bindersOf binds'))))
 
        return binds'
   where
@@ -600,8 +601,6 @@ specProgram dflags us binds
     go (bind:binds) = go binds                                 `thenSM` \ (binds', uds) ->
                      specBind top_subst bind uds       `thenSM` \ (bind', uds') ->
                      returnSM (bind' ++ binds', uds')
-
-dump_specs var = pprCoreRules var (idSpecialisation var)
 \end{code}
 
 %************************************************************************
@@ -785,9 +784,9 @@ specDefn :: Subst                   -- Subst to use for RHS
 
 specDefn subst calls (fn, rhs)
        -- The first case is the interesting one
-  |  n_tyvars == length rhs_tyvars     -- Rhs of fn's defn has right number of big lambdas
-  && n_dicts  <= length rhs_bndrs      -- and enough dict args
-  && not (null calls_for_me)           -- And there are some calls to specialise
+  |  rhs_tyvars `lengthIs` n_tyvars    -- Rhs of fn's defn has right number of big lambdas
+  && rhs_bndrs  `lengthAtLeast` n_dicts        -- and enough dict args
+  && notNull calls_for_me              -- And there are some calls to specialise
   && not (isDataConWrapId fn)          -- And it's not a data con wrapper, which have
                                        -- stupid overloading that simply discard the dictionary
 
@@ -848,7 +847,7 @@ specDefn subst calls (fn, rhs)
                        UsageDetails,                   -- Usage details from specialised body
                        CoreRule)                       -- Info for the Id's SpecEnv
     spec_call (CallKey call_ts, (call_ds, call_fvs))
-      = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
                -- Calls are only recorded for properly-saturated applications
        
        -- Suppose f's defn is  f = /\ a b c d -> \ d1 d2 -> rhs        
@@ -888,7 +887,7 @@ 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 = Rule (_PK_ ("SPEC " ++ showSDoc (ppr fn)))
+           spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn)))
                                AlwaysActive
                                (poly_tyvars ++ rhs_dicts')
                                inst_args 
@@ -910,8 +909,8 @@ specDefn subst calls (fn, rhs)
 
       where
        my_zipEqual doc xs ys 
-        | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
-        | otherwise              = zipEqual doc xs ys
+        | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+        | otherwise               = zipEqual doc xs ys
 
 dropInline :: CoreExpr -> (Bool, CoreExpr) 
 dropInline (Note InlineMe rhs) = (True, rhs)
@@ -1004,8 +1003,12 @@ callDetailsToList calls = [ (id,tys,dicts)
 
 mkCallUDs subst f args 
   | null theta
-  || length spec_tys /= n_tyvars
-  || length dicts    /= n_dicts
+  || not (all isClassPred theta)       
+       -- Only specialise if all overloading is on class params. 
+       -- In ptic, with implicit params, the type args
+       -- *don't* say what the value of the implicit param is!
+  || not (spec_tys `lengthIs` n_tyvars)
+  || not ( dicts   `lengthIs` n_dicts)
   || maybeToBool (lookupRule (\act -> True) (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
@@ -1026,10 +1029,9 @@ mkCallUDs subst f args
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
     
-    mk_spec_ty tyvar ty | tyvar `elemVarSet` constrained_tyvars
-                       = Just ty
-                       | otherwise
-                       = Nothing
+    mk_spec_ty tyvar ty 
+       | tyvar `elemVarSet` constrained_tyvars = Just ty
+       | otherwise                             = Nothing
 
 ------------------------------------------------------------                   
 plusUDs :: UsageDetails -> UsageDetails -> UsageDetails