From: simonpj <unknown>
Date: Tue, 22 Jun 1999 16:31:20 +0000 (+0000)
Subject: [project @ 1999-06-22 16:31:19 by simonpj]
X-Git-Tag: Approximately_9120_patches~6109
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=acaa2124a9427aec9ccc96e0c8b6e067a85916e0;p=ghc-hetmet.git

[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
--- 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
--- 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)) ->