X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;fp=compiler%2FdeSugar%2FDesugar.lhs;h=603c8584c0295e917d4f2b3ec09907d812c09bc1;hp=37a3cf9236ab918572163d197892fa0ffdff7ae1;hb=6cec61d14a324285dbb8ce73d4c7215f1f8d6766;hpb=11b33eaeaef39fcba8ee9258213068ed90362aa7

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 37a3cf9..603c858 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -18,6 +18,7 @@ import Id
 import Name
 import CoreSyn
 import CoreSubst
+import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
 import PprCore
 import DsMonad
 import DsExpr
@@ -40,6 +41,8 @@ import MonadUtils
 import OrdList
 import Data.List
 import Data.IORef
+import PrelNames
+import UniqSupply
 \end{code}
 
 %************************************************************************
@@ -89,7 +92,7 @@ deSugar hsc_env
               <- case target of
 	           HscNothing ->
                        return (emptyMessages,
-                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
+                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
 			 <- if (opt_Hpc
@@ -105,6 +108,8 @@ deSugar hsc_env
                           ; (ds_fords, foreign_prs) <- dsForeigns fords
                           ; ds_rules <- mapMaybeM dsRule rules
                           ; ds_vects <- mapM dsVect vects
+                          ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
+                          ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
                           ; let hpc_init
                                   | opt_Hpc   = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
@@ -112,11 +117,11 @@ deSugar hsc_env
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules, ds_vects
                                    , ds_fords `appendStubC` hpc_init
-                                   , ds_hpc_info, modBreaks) }
+                                   , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
+           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc) -> do
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
@@ -141,7 +146,17 @@ deSugar hsc_env
 	      		 -- The simpleOptPgm gets rid of type 
 			 -- bindings plus any stupid dead code
 
-	; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+        ; dumpIfSet_dyn dflags Opt_D_coqpass "Coq Pass Output" $ text $ coqPassCoreToString ds_binds
+
+        ; ds_binds' <- if dopt Opt_F_coqpass dflags
+                       then do { us <- mkSplitUniqSupply '~'
+                               ; return $ coqPassCoreToCore hetmet_brak hetmet_esc us ds_binds
+                               }
+                       else return ds_binds
+
+        ; dumpIfSet_dyn dflags Opt_D_dump_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
+
+	; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
 	; deps <- mkDependencies tcg_env
@@ -163,7 +178,7 @@ deSugar hsc_env
 		mg_inst_env     = inst_env,
 		mg_fam_inst_env = fam_inst_env,
 	        mg_rules     	= ds_rules_for_imps,
-		mg_binds     	= ds_binds,
+		mg_binds     	= ds_binds',
 		mg_foreign   	= ds_fords,
 		mg_hpc_info  	= ds_hpc_info,
                 mg_modBreaks    = modBreaks,