Commit acaa2124 authored by simonpj's avatar simonpj
Browse files

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

Pragmas for default decls
parent 2059de7c
......@@ -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 $
......
......@@ -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)) ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment