X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=0765a94f9569dfe1dc800b075c9bcfd9307e7fcf;hb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;hp=49f8939bbd841ff579dd7e15872065e74c186785;hpb=ea659be5faea43df1b2c113d2f22947dff23367e;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 49f8939..0765a94 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -4,18 +4,18 @@
 \section[Desugar]{@deSugar@: the main function}
 
 \begin{code}
-module Desugar ( deSugar ) where
+module Desugar ( deSugar, deSugarExpr ) where
 
 #include "HsVersions.h"
 
 import CmdLineOpts	( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
 import HsSyn		( MonoBinds, RuleDecl(..), RuleBndr(..), 
 			  HsExpr(..), HsBinds(..), MonoBinds(..) )
-import TcHsSyn		( TypecheckedRuleDecl )
+import TcHsSyn		( TypecheckedRuleDecl, TypecheckedHsExpr )
 import TcModule		( TcResults(..) )
 import Id		( Id )
 import CoreSyn
-import PprCore		( pprIdCoreRule )
+import PprCore		( pprIdCoreRule, pprCoreExpr )
 import Subst		( substExpr, mkSubst, mkInScopeSet )
 import DsMonad
 import DsExpr		( dsExpr )
@@ -25,14 +25,15 @@ import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
 				-- depends on DsExpr.hi-boot.
 import Module		( Module )
 import Id		( Id )
+import NameEnv		( lookupNameEnv )
 import VarEnv
 import VarSet
 import Bag		( isEmptyBag )
 import CoreLint		( showPass, endPass )
-import ErrUtils		( doIfSet, pprBagOfWarnings )
+import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings )
 import Outputable
 import UniqSupply	( mkSplitUniqSupply )
-import HscTypes		( HomeSymbolTable )
+import HscTypes		( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType,  )
 \end{code}
 
 %************************************************************************
@@ -46,14 +47,13 @@ start.
 
 \begin{code}
 deSugar :: DynFlags
+	-> PersistentCompilerState -> HomeSymbolTable
 	-> Module -> PrintUnqualified
-	-> HomeSymbolTable
         -> TcResults
-	-> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
+	-> IO ([CoreBind], [(Id,CoreRule)], (SDoc, SDoc, [CoreBndr]))
 
-deSugar dflags mod_name unqual hst
-        (TcResults {tc_env   = global_val_env,
-		    tc_pcs   = pcs,
+deSugar dflags pcs hst mod_name unqual
+        (TcResults {tc_env   = local_type_env,
 		    tc_binds = all_binds,
 		    tc_rules = rules,
 		    tc_fords = fo_decls})
@@ -61,26 +61,64 @@ deSugar dflags mod_name unqual hst
 	; us <- mkSplitUniqSupply 'd'
 
 	-- Do desugaring
-	; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name
+	; let (result, ds_warns) = initDs dflags us lookup mod_name
 					  (dsProgram mod_name all_binds rules fo_decls)    
-	      (ds_binds, ds_rules, _, _, _) = result
+	      (ds_binds, ds_rules, _) = result
 
 	-- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
 		  (printErrs unqual (pprBagOfWarnings ds_warns))
 
 	-- Lint result if necessary
-        ; let do_dump_ds = dopt Opt_D_dump_ds dflags
-        ; endPass dflags "Desugar" do_dump_ds ds_binds
+        ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
 
 	-- Dump output
-	; doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
+	; doIfSet (dopt Opt_D_dump_ds dflags) 
+		(printDump (ppr_ds_rules ds_rules))
 
         ; return result
 	}
 
--- deSugarExpr dflags unqual hst tc_expr
---  = do	{
+  where
+	-- The lookup function passed to initDs is used for well-known Ids, 
+	-- such as fold, build, cons etc, so the chances are
+	-- it'll be found in the package symbol table.  That's
+	-- why we don't merge all these tables
+    pte      = pcs_PTE pcs
+    lookup n = case lookupType hst pte n of {
+		 Just (AnId v) -> v ;
+		 other -> 
+	       case lookupNameEnv local_type_env n of
+		 Just (AnId v) -> v ;
+		 other	       -> pprPanic "Desugar: lookup:" (ppr n)
+               }
+
+deSugarExpr :: DynFlags
+	    -> PersistentCompilerState -> HomeSymbolTable
+	    -> Module -> PrintUnqualified
+ 	    -> TypecheckedHsExpr
+	    -> IO CoreExpr
+deSugarExpr dflags pcs hst mod_name unqual tc_expr
+  = do	{ showPass dflags "Desugar"
+	; us <- mkSplitUniqSupply 'd'
+
+	-- Do desugaring
+	; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr)    
+
+	-- Display any warnings
+        ; doIfSet (not (isEmptyBag ds_warns))
+		  (printErrs unqual (pprBagOfWarnings ds_warns))
+
+	-- Dump output
+	; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
+
+        ; return core_expr
+	}
+  where
+    pte      = pcs_PTE pcs
+    lookup n = case lookupType hst pte n of
+		 Just (AnId v) -> v 
+		 other	       -> pprPanic "Desugar: lookup:" (ppr n)
 
 dsProgram mod_name all_binds rules fo_decls
   = dsMonoBinds auto_scc all_binds []	`thenDs` \ core_prs ->
@@ -96,7 +134,7 @@ dsProgram mod_name all_binds rules fo_decls
 	local_binders = mkVarSet (bindersOfBinds ds_binds)
     in
     mapDs (dsRule local_binders) rules	`thenDs` \ rules' ->
-    returnDs (ds_binds, rules', h_code, c_code, fe_binders)
+    returnDs (ds_binds, rules', (h_code, c_code, fe_binders))
   where
     auto_scc | opt_SccProfilingOn = TopLevel
 	     | otherwise          = NoSccs