[project @ 2000-09-14 13:46:39 by simonpj]

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

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 2aa24b7..b45b8c5 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -10,30 +10,26 @@ module Desugar ( deSugar ) where
 
 import CmdLineOpts     ( opt_D_dump_ds )
 import HsSyn           ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) )
-import HsCore          ( UfRuleBody(..) )
-import TcHsSyn         ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl )
+import TcHsSyn         ( TypecheckedRuleDecl )
 import TcModule                ( TcResults(..) )
 import CoreSyn
 import Rules           ( ProtoCoreRule(..), pprProtoCoreRule )
-import Subst           ( substExpr, mkSubst )
+import Subst           ( substExpr, mkSubst, mkInScopeSet )
 import DsMonad
 import DsExpr          ( dsExpr )
 import DsBinds         ( dsMonoBinds, AutoScc(..) )
 import DsForeign       ( dsForeigns )
-import DsUtils
 import DsExpr          ()      -- Forces DsExpr to be compiled; DsBinds only
                                -- depends on DsExpr.hi-boot.
-import Module          ( Module, moduleString )
-import Id              ( Id )
-import Name            ( isLocallyDefined )
+import Module          ( Module )
 import VarEnv
 import VarSet
-import Bag             ( isEmptyBag, unionBags )
+import Bag             ( isEmptyBag )
 import CmdLineOpts     ( opt_SccProfilingOn )
 import CoreLint                ( beginPass, endPass )
 import ErrUtils                ( doIfSet, pprBagOfWarnings )
 import Outputable
-import UniqSupply      ( splitUniqSupply, UniqSupply )
+import UniqSupply      ( UniqSupply )
 \end{code}
 
 %************************************************************************
@@ -76,12 +72,18 @@ deSugar mod_name us (TcResults {tc_env = global_val_env,
 
 dsProgram mod_name all_binds rules fo_decls
   = dsMonoBinds auto_scc all_binds []  `thenDs` \ core_prs ->
-    dsForeigns mod_name fo_decls       `thenDs` \ (fi_binds, fe_binds, h_code, c_code) ->
-    mapDs dsRule rules                 `thenDs` \ rules' ->
-    let 
-       ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
-       fe_binders = bindersOfBinds fe_binds
+    dsForeigns mod_name fo_decls       `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
+    let
+       ds_binds      = [Rec (foreign_binds ++ core_prs)]
+       -- Notice that we put the whole lot in a big Rec, even the foreign binds
+       -- When compiling PrelFloat, which defines data Float = F# Float#
+       -- we want F# to be in scope in the foreign marshalling code!
+       -- You might think it doesn't matter, but the simplifier brings all top-level
+       -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+       local_binders = mkVarSet (bindersOfBinds ds_binds)
     in
+    mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
     returnDs (ds_binds, rules', h_code, c_code, fe_binders)
   where
     auto_scc | opt_SccProfilingOn = TopLevel
@@ -101,19 +103,19 @@ ppr_ds_rules rules
 %************************************************************************
 
 \begin{code}
-dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule
-dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc)
-  = returnDs (ProtoCoreRule False {- non-local -} fn 
-                           (Rule name all_vars args rhs))
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
+dsRule in_scope (IfaceRuleOut fn rule)
+  = returnDs (ProtoCoreRule False {- non-local -} fn rule)
     
-dsRule (RuleDecl name sig_tvs vars lhs rhs loc)
+dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
   = putSrcLocDs loc            $
     ds_lhs all_vars lhs                `thenDs` \ (fn, args) ->
     dsExpr rhs                 `thenDs` \ core_rhs ->
     returnDs (ProtoCoreRule True {- local -} fn
-                           (Rule name all_vars args core_rhs))
+                           (Rule name tpl_vars args core_rhs))
   where
-    all_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+    tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+    all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
 
 ds_lhs all_vars lhs
   = let
@@ -132,7 +134,7 @@ ds_lhs all_vars lhs
                        -- Note recursion here... substitution won't terminate
                        -- if there is genuine recursion... which there isn't
 
-       subst = mkSubst (mkVarSet all_vars) subst_env
+       subst = mkSubst all_vars subst_env
        body'' = substExpr subst body'
     in