[project @ 2000-10-18 14:04:12 by sewardj]

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

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 557ac73..5090a9e 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -8,8 +8,9 @@ module Desugar ( deSugar ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( opt_D_dump_ds )
-import HsSyn           ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) )
+import CmdLineOpts     ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
+import HsSyn           ( MonoBinds, RuleDecl(..), RuleBndr(..), 
+                         HsExpr(..), HsBinds(..), MonoBinds(..) )
 import TcHsSyn         ( TypecheckedRuleDecl )
 import TcModule                ( TcResults(..) )
 import CoreSyn
@@ -25,11 +26,11 @@ import Module               ( Module )
 import VarEnv
 import VarSet
 import Bag             ( isEmptyBag )
-import CmdLineOpts     ( opt_SccProfilingOn )
 import CoreLint                ( beginPass, endPass )
 import ErrUtils                ( doIfSet, pprBagOfWarnings )
 import Outputable
 import UniqSupply      ( UniqSupply )
+import HscTypes                ( HomeSymbolTable )
 \end{code}
 
 %************************************************************************
@@ -42,20 +43,24 @@ The only trick here is to get the @DsMonad@ stuff off to a good
 start.
 
 \begin{code}
-deSugar :: Module 
+deSugar :: DynFlags
+       -> Module 
        -> UniqSupply
+       -> HomeSymbolTable
         -> TcResults
        -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr])
 
-deSugar mod_name us (TcResults {tc_env = global_val_env,
-                               tc_binds = all_binds,
-                               tc_rules = rules,
-                               tc_fords = fo_decls})
+deSugar dflags mod_name us hst
+        (TcResults {tc_env   = global_val_env,
+                   tc_pcs   = pcs,
+                   tc_binds = all_binds,
+                   tc_rules = rules,
+                   tc_fords = fo_decls})
   = do
-       beginPass "Desugar"
+       beginPass dflags "Desugar"
        -- Do desugaring
        let (result, ds_warns) = 
-               initDs us global_val_env mod_name
+               initDs dflags us (hst,pcs,global_val_env) mod_name
                        (dsProgram mod_name all_binds rules fo_decls)    
            (ds_binds, ds_rules, _, _, _) = result
 
@@ -64,18 +69,24 @@ deSugar mod_name us (TcResults {tc_env = global_val_env,
                (printErrs (pprBagOfWarnings ds_warns))
 
         -- Lint result if necessary
-        endPass "Desugar" opt_D_dump_ds ds_binds
+        let do_dump_ds = dopt Opt_D_dump_ds dflags
+        endPass dflags "Desugar" do_dump_ds ds_binds
 
-       doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules))
+       doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
 
         return result
 
 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) ->
+    dsForeigns mod_name fo_decls       `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
     let
-       ds_binds      = fi_binds ++ [Rec core_prs] ++ fe_binds
-       fe_binders    = bindersOfBinds fe_binds
+       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' ->