X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDesugar.lhs;h=14e4eea0d15935a70a770877c2ed1bc661c3eacd;hp=28984608d993506a665e83868765df3690e0a912;hb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hpb=29dae53960f63314456cb2b25d428faf87f4af04

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 2898460..14e4eea 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -71,12 +71,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"
@@ -90,7 +91,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
@@ -100,19 +101,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
@@ -181,6 +183,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)
@@ -396,3 +399,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}