X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=cbf64e220fbf1b47a53cd453501094ce6610a2da;hb=2c1c4d3540e5671274d45a473f1d1da5d37f76c1;hp=073e87390f3c009fd98e4f9de4716bf96fffbbd3;hpb=0656c72a8f4fda30c348bdf40449d105e4ce00ce;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 073e873..cbf64e2 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
@@ -69,12 +70,13 @@ deSugar hsc_env
 	    	    	    tcg_anns         = anns,
 			    tcg_binds        = binds,
 		    	    tcg_imp_specs    = imp_specs,
-			    tcg_ev_binds     = ev_binds,
-			    tcg_fords        = fords,
-			    tcg_rules        = rules,
-		    	    tcg_insts        = insts,
-		    	    tcg_fam_insts    = fam_insts,
-			    tcg_hpc          = other_hpc_info })
+                            tcg_ev_binds     = ev_binds,
+                            tcg_fords        = fords,
+                            tcg_rules        = rules,
+                            tcg_vects        = vects,
+                            tcg_insts        = insts,
+                            tcg_fam_insts    = fam_insts,
+                            tcg_hpc          = other_hpc_info })
 
   = do	{ let dflags = hsc_dflags hsc_env
         ; showPass dflags "Desugar"
@@ -88,7 +90,7 @@ deSugar hsc_env
               <- case target of
 	           HscNothing ->
                        return (emptyMessages,
-                               Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
+                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
 			 <- if (opt_Hpc
@@ -98,19 +100,20 @@ deSugar hsc_env
                                                            (typeEnvTyCons type_env) binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do
-		       do { ds_ev_binds <- dsEvBinds ev_binds
-		          ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
+                       do { ds_ev_binds <- dsEvBinds ev_binds
+                          ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
                           ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
-	                  ; (ds_fords, foreign_prs) <- dsForeigns fords
-		          ; rules <- mapMaybeM dsRule rules
-		          ; return ( ds_ev_binds
+                          ; (ds_fords, foreign_prs) <- dsForeigns fords
+                          ; ds_rules <- mapMaybeM dsRule rules
+                          ; ds_vects <- mapM dsVect vects
+                          ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
-                                   , spec_rules ++ rules
+                                   , spec_rules ++ ds_rules, ds_vects
                                    , ds_fords, ds_hpc_info, modBreaks) }
 
-	; case mb_res of {
-	   Nothing -> return (msgs, Nothing) ;
-	   Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
+        ; 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
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
@@ -135,9 +138,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
 
-        ; used_names <- mkUsedNames tcg_env
+        ; ds_binds' <- if dopt Opt_F_coqpass dflags
+                       then return $ coqPassCoreToCore 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
 
         ; let mod_guts = ModGuts {	
@@ -161,6 +172,7 @@ deSugar hsc_env
 		mg_foreign   	= ds_fords,
 		mg_hpc_info  	= ds_hpc_info,
                 mg_modBreaks    = modBreaks,
+                mg_vect_decls   = ds_vects,
                 mg_vect_info    = noVectInfo
               }
         ; return (msgs, Just mod_guts)
@@ -374,3 +386,26 @@ That keeps the desugaring of list comprehensions simple too.
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
+
+
+%************************************************************************
+%*                                                                      *
+%*              Desugaring vectorisation declarations
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+dsVect :: LVectDecl Id -> DsM CoreVect
+dsVect (L loc (HsVect v rhs))
+  = putSrcSpanDs loc $ 
+    do { rhs' <- fmapMaybeM dsLExpr rhs
+       ; return $ Vect (unLoc v) rhs'
+  	   }
+-- dsVect (L loc (HsVect v Nothing))
+--   = return $ Vect v Nothing
+-- dsVect (L loc (HsVect v (Just rhs)))
+--   = putSrcSpanDs loc $ 
+--     do { rhs' <- dsLExpr rhs
+--        ; return $ Vect v (Just rhs')
+--       }
+\end{code}