[project @ 1999-06-22 16:31:19 by simonpj]

Pragmas for default decls

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 0db0d82..2131f60 100644 (file)
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -29,7 +29,7 @@ import CmdLineOpts    ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs,
                          opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnDicts
                        )
 import CostCentre      ( CostCentre, mkAutoCC, IsCafCC(..) )
-import Id              ( idType, idName, isUserExportedId, Id )
+import Id              ( idType, idName, isUserExportedId, isSpecPragmaId, Id )
 import NameSet
 import VarEnv
 import VarSet
@@ -70,7 +70,17 @@ dsMonoBinds _ (VarMonoBind var expr) rest
        -- we only need do this here
     addDictScc var core_expr   `thenDs` \ core_expr' ->
 
-    returnDs ((var, core_expr') : rest)
+    let
+       -- Gross hack to prevent inlining into SpecPragmaId rhss
+       -- Consider     fromIntegral = fromInteger . toInteger
+       --              spec1 = fromIntegral Int Float
+       -- Even though fromIntegral is small we don't want to inline
+       -- it inside spec1, so that we collect the specialised call
+       -- Solution: make spec1 an INLINE thing.  
+       core_expr'' = mkInline (isSpecPragmaId var) core_expr'
+    in  
+
+    returnDs ((var, core_expr'') : rest)
 
 dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
   = putSrcLocDs locn   $

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 794eb83..264776a 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -14,7 +14,7 @@ import HsSyn          ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
                          InPat(..), HsBinds(..), GRHSs(..),
                          HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
                          unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
-                         isClassDecl, isClassOpSig, collectMonoBinders
+                         isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
                        )
 import HsPragmas       ( ClassPragmas(..) )
 import BasicTypes      ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
@@ -352,7 +352,7 @@ tcClassDecl2 (ClassDecl context class_name
                    ]
     in
        -- Generate bindings for the default methods
-    tcDefaultMethodBinds clas default_binds            `thenTc` \ (const_insts, meth_binds) ->
+    tcDefaultMethodBinds clas default_binds class_sigs         `thenTc` \ (const_insts, meth_binds) ->
 
     returnTc (const_insts,
              meth_binds `AndMonoBinds` andMonoBindList sel_binds)
@@ -423,9 +423,10 @@ dfun.Foo.List
 tcDefaultMethodBinds
        :: Class
        -> RenamedMonoBinds
+       -> [RenamedSig]
        -> TcM s (LIE, TcMonoBinds)
 
-tcDefaultMethodBinds clas default_binds
+tcDefaultMethodBinds clas default_binds sigs
   =    -- Check that the default bindings come from this class
     checkFromThisClass clas op_sel_ids default_binds   `thenNF_Tc_`
 
@@ -434,6 +435,7 @@ tcDefaultMethodBinds clas default_binds
 
     returnTc (plusLIEs const_lies, andMonoBindList defm_binds)
   where
+    prags = filter isPragSig sigs
 
     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
 
@@ -463,7 +465,7 @@ tcDefaultMethodBinds clas default_binds
        in
        tcExtendTyVarEnvForMeths tyvars clas_tyvars (
            tcMethodBind clas origin clas_tyvars inst_tys theta
-                        default_binds [{-no prags-}] False
+                        default_binds prags False
                         sel_id_w_dm    
         )                                      `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->