\begin{code}
module Desugar ( deSugar, deSugarExpr ) where
+import TysWiredIn (unitDataConId)
import DynFlags
import StaticFlags
import HscTypes
import OrdList
import Data.List
import Data.IORef
+import Control.Exception ( catch, ErrorCall, Exception(..) )
\end{code}
%************************************************************************
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
; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
-
+{-
+ ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds)
+ ; let uhandler (err::ErrorCall)
+ = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof"
+ (text $ "\\begin{verbatim}\n" ++
+ show err ++
+ "\\end{verbatim}\n\n")
+ in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $
+ (vcat (map (\ bind -> let e = case bind of
+ NonRec b e -> e
+ Rec lve -> Let (Rec lve) (Var unitDataConId)
+ in text $ "\\begin{verbatim}\n" ++
+ (showSDoc $ pprCoreBindings ds_binds) ++
+ "\\end{verbatim}\n\n" ++
+ "$$\n"++
+ (core2proofAndShow e) ++
+ "$$\n"
+ ) ds_binds))) `Control.Exception.catch` uhandler
+-}
; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
- ; used_names <- mkUsedNames tcg_env
+ ; 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)
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
let dflags = hsc_dflags hsc_env
- showPass dflags "Desugar"
+ showPass dflags "Desugarz"
-- Do desugaring
(msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
Nothing -> return (msgs, Nothing)
Just expr -> do
+{-
-- Dump output
- dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+ dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (text $ "$$\n"++(core2proofAndShow expr)++"$$\n")
+-}
return (msgs, Just expr)
\end{code}
= putSrcSpanDs loc $
do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
- ; lhs' <- unsetOptM Opt_EnableRewriteRules $
- dsLExpr lhs -- Note [Desugaring RULE left hand sides]
+ ; lhs' <- unsetOptM Opt_EnableRewriteRules $
+ unsetOptM Opt_WarnIdentities $
+ dsLExpr lhs -- Note [Desugaring RULE left hand sides]
; rhs' <- dsLExpr rhs
; return (Just rule)
} } }
\end{code}
+
Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
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}
projects / ghc-hetmet.git / blobdiff