[project @ 2000-03-08 17:48:24 by simonmar]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsBinds.lhs

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 0db0d82..c43f985 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   $
@@ -195,8 +205,8 @@ addAutoScc :: AutoScc               -- if needs be, decorate toplevs?
 
 addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) 
  | do_auto_scc && worthSCC core_expr
-     = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
-       returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod grp NotCafCC)) core_expr)
+     = getModuleDs `thenDs` \ mod ->
+       returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod NotCafCC)) core_expr)
  where do_auto_scc = isJust maybe_auto_scc
        maybe_auto_scc = auto_scc_fn bndr
        (Just top_bndr) = maybe_auto_scc