[project @ 2001-06-11 12:24:51 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index c43f985..f045619 100644 (file)
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -17,29 +17,23 @@ import {-# SOURCE #-}       DsExpr( dsExpr )
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
-import CoreUtils       ( coreExprType )
+import CoreUtils       ( exprType, mkInlineMe, mkSCC )
 import TcHsSyn         ( TypecheckedMonoBinds )
 import DsMonad
 import DsGRHSs         ( dsGuarded )
 import DsUtils
 import Match           ( matchWrapper )
 
-import BasicTypes       ( RecFlag(..) )
-import CmdLineOpts     ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, 
-                         opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnDicts
-                       )
-import CostCentre      ( CostCentre, mkAutoCC, IsCafCC(..) )
-import Id              ( idType, idName, isUserExportedId, isSpecPragmaId, Id )
+import CmdLineOpts     ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
+import CostCentre      ( mkAutoCC, IsCafCC(..) )
+import Id              ( idType, idName, isExportedId, isSpecPragmaId, Id )
 import NameSet
-import VarEnv
 import VarSet
-import Type            ( mkTyVarTy, isDictTy )
+import Type            ( mkTyVarTy )
 import Subst           ( mkTyVarSubst, substTy )
 import TysWiredIn      ( voidTy )
 import Outputable
-
-import Maybe
-import IOExts (trace)
+import Maybe           ( isJust )
 \end{code}
 
 %************************************************************************
@@ -84,11 +78,9 @@ dsMonoBinds _ (VarMonoBind var expr) rest
 
 dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
   = putSrcLocDs locn   $
-    matchWrapper (FunMatch fun) matches error_string   `thenDs` \ (args, body) ->
+    matchWrapper (FunRhs fun) matches                  `thenDs` \ (args, body) ->
     addAutoScc auto_scc (fun, mkLams args body)                `thenDs` \ pair ->
     returnDs (pair : rest)
-  where
-    error_string = "function " ++ showSDoc (ppr fun)
 
 dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
   = putSrcLocDs locn $
@@ -97,8 +89,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
     mapDs (addAutoScc auto_scc) sel_binds      `thenDs` \ sel_binds ->
     returnDs (sel_binds ++ rest)
 
-       -- Common case: one exported variable
-       -- All non-recursive bindings come through this way
+       -- Common special case: no type or dictionary abstraction
+dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
+  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+    let 
+       exports' = [(global, Var local) | (_, global, local) <- exports]
+    in
+    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+
+       -- Another common case: one exported variable
+       -- Non-recursive bindings come through this way
 dsMonoBinds auto_scc
      (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
   = ASSERT( all (`elem` tyvars) all_tyvars )
@@ -113,27 +113,19 @@ dsMonoBinds auto_scc
     in
     returnDs (global' : rest)
 
-       -- Another common special case: no type or dictionary abstraction
-dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
-  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
-    let 
-       exports' = [(global, Var local) | (_, global, local) <- exports]
-    in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
-
 dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
   = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
        core_binds = [Rec (addLocalInlines exports inlines core_prs)]
 
        tup_expr      = mkTupleExpr locals
-       tup_ty        = coreExprType tup_expr
+       tup_ty        = exprType tup_expr
        poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
                        mkDsLets core_binds tup_expr
        locals        = [local | (_, _, local) <- exports]
        local_tys     = map idType locals
     in
-    newSysLocalDs (coreExprType poly_tup_expr)         `thenDs` \ poly_tup_id ->
+    newSysLocalDs (exprType poly_tup_expr)             `thenDs` \ poly_tup_id ->
     let
        dict_args = map Var dicts
 
@@ -165,7 +157,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
 
 \begin{code}
 mkInline :: Bool -> CoreExpr -> CoreExpr
-mkInline True  body = Note InlineMe body
+mkInline True  body = mkInlineMe body
 mkInline False body = body
 
 addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
@@ -194,7 +186,7 @@ addSccs NoSccs   exports = NoSccs
 addSccs TopLevel exports 
   = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of
                                (exp:_)  | opt_AutoSccsOnAllToplevs || 
-                                           (isUserExportedId exp && 
+                                           (isExportedId exp && 
                                             opt_AutoSccsOnExportedToplevs)
                                        -> Just exp
                                _ -> Nothing)
@@ -204,18 +196,15 @@ addAutoScc :: AutoScc             -- if needs be, decorate toplevs?
           -> DsM (Id, CoreExpr)
 
 addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr) 
- | do_auto_scc && worthSCC core_expr
+ | do_auto_scc
      = getModuleDs `thenDs` \ mod ->
-       returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod NotCafCC)) core_expr)
+       returnDs (bndr, mkSCC (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
+
 addAutoScc _ pair
      = returnDs pair
-
-worthSCC (Note (SCC _) _) = False
-worthSCC (Con _ _)        = False
-worthSCC core_expr        = True
 \end{code}
 
 If profiling and dealing with a dict binding,