import Name
import CoreSyn
import CoreSubst
+import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
import PprCore
import DsMonad
import DsExpr
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"
<- 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
(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
-- 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 {
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)
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}