[project @ 2003-06-24 07:58:18 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 546c80e..97c844e 100644 (file)
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -14,23 +14,23 @@ module DsBinds ( dsMonoBinds, AutoScc(..) ) where
 
 
 import {-# SOURCE #-}  DsExpr( dsExpr )
+import DsMonad
+import DsGRHSs         ( dsGuarded )
+import DsUtils
 
 import HsSyn           -- lots of things
 import CoreSyn         -- lots of things
 import CoreUtils       ( exprType, mkInlineMe, mkSCC )
 import TcHsSyn         ( TypecheckedMonoBinds )
-import DsMonad
-import DsGRHSs         ( dsGuarded )
-import DsUtils
 import Match           ( matchWrapper )
 
 import CmdLineOpts     ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
 import CostCentre      ( mkAutoCC, IsCafCC(..) )
-import Id              ( idType, idName, isUserExportedId, isSpecPragmaId, Id )
+import Id              ( idType, idName, isExportedId, isSpecPragmaId, Id )
 import NameSet
 import VarSet
-import Type            ( mkTyVarTy )
-import Subst           ( mkTyVarSubst, substTy )
+import TcType          ( mkTyVarTy )
+import Subst           ( substTyWith )
 import TysWiredIn      ( voidTy )
 import Outputable
 import Maybe           ( isJust )
@@ -54,9 +54,6 @@ dsMonoBinds auto_scc (AndMonoBinds  binds_1 binds_2) rest
   = dsMonoBinds auto_scc binds_2 rest  `thenDs` \ rest' ->
     dsMonoBinds auto_scc binds_1 rest'
 
-dsMonoBinds _ (CoreMonoBind var core_expr) rest
-  = returnDs ((var, core_expr) : rest)
-
 dsMonoBinds _ (VarMonoBind var expr) rest
   = dsExpr expr                        `thenDs` \ core_expr ->
 
@@ -78,11 +75,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 (idName 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 $
@@ -92,12 +87,16 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
     returnDs (sel_binds ++ rest)
 
        -- Common special case: no type or dictionary abstraction
+       -- For the (rare) case when there are some mixed-up
+       -- dictionary bindings (for which a Rec is convenient)
+       -- we reply on the enclosing dsBind to wrap a Rec around.
 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]
+       core_prs' = addLocalInlines exports inlines core_prs
+       exports'  = [(global, Var local) | (_, global, local) <- exports]
     in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+    returnDs (core_prs' ++ exports' ++ rest)
 
        -- Another common case: one exported variable
        -- Non-recursive bindings come through this way
@@ -108,22 +107,26 @@ dsMonoBinds auto_scc
     let 
        -- Always treat the binds as recursive, because the typechecker
        -- makes rather mixed-up dictionary bindings
-       core_binds = [Rec core_prs]
-       global'    = (global, mkInline (idName global `elemNameSet` inlines) $
+       core_bind = Rec core_prs
+
+       -- The mkInline does directly what the 
+       -- addLocalInlines do in the other cases
+       export'    = (global, mkInline (idName global `elemNameSet` inlines) $
                              mkLams tyvars $ mkLams dicts $ 
-                             mkDsLets core_binds (Var local))
+                             Let core_bind (Var local))
     in
-    returnDs (global' : rest)
+    returnDs (export' : 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)]
+       -- Rec because of mixed-up dictionary bindings
+       core_bind = Rec (addLocalInlines exports inlines core_prs)
 
        tup_expr      = mkTupleExpr locals
        tup_ty        = exprType tup_expr
        poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
-                       mkDsLets core_binds tup_expr
+                       Let core_bind tup_expr
        locals        = [local | (_, _, local) <- exports]
        local_tys     = map idType locals
     in
@@ -134,16 +137,16 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
        mk_bind (tyvars, global, local) n       -- locals !! n == local
          =     -- Need to make fresh locals to bind in the selector, because
                -- some of the tyvars will be bound to voidTy
-           newSysLocalsDs (map (substTy env) local_tys)        `thenDs` \ locals' ->
-           newSysLocalDs  (substTy env tup_ty)                 `thenDs` \ tup_id ->
+           newSysLocalsDs (map substitute local_tys)   `thenDs` \ locals' ->
+           newSysLocalDs  (substitute tup_ty)          `thenDs` \ tup_id ->
            returnDs (global, mkLams tyvars $ mkLams dicts $
                              mkTupleSelector locals' (locals' !! n) tup_id $
                              mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
          where
            mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
                                | otherwise               = voidTy
-           ty_args = map mk_ty_arg all_tyvars
-           env     = mkTyVarSubst all_tyvars ty_args
+           ty_args    = map mk_ty_arg all_tyvars
+           substitute = substTyWith all_tyvars ty_args
     in
     zipWithDs mk_bind exports [0..]            `thenDs` \ export_binds ->
      -- don't scc (auto-)annotate the tuple itself.
@@ -188,7 +191,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)