debugTraceMsg, debugTraceMsgS,
dumpIfSet_dyn,
+ lookupOrigCoreM,
+
#ifdef GHCI
-- * Getting 'Name's
thNameToGhcName
import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
-import Module ( PackageId, Module )
+import Module ( Module )
import DynFlags
import StaticFlags
import Rules ( RuleBase )
import Control.Monad
import Prelude hiding ( read )
+import OccName
+import IfaceEnv
+import Name
+import SrcLoc
+import Control.Exception.Base
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
| CoreCSE
| CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
-- matching this string
- | CoreDoVectorisation PackageId
+ | CoreDoVectorisation
| CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
-coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
-coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
-coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
-coreDumpFlag CorePrep = Just Opt_D_dump_prep
+coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep = Just Opt_D_dump_prep
coreDumpFlag CoreDoPrintCore = Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Nothing
ppr CoreDoSpecialising = ptext (sLit "Specialise")
ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
ppr CoreCSE = ptext (sLit "Common sub-expression")
- ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
- ppr CoreDesugar = ptext (sLit "Desugar")
- ppr CoreTidy = ptext (sLit "Tidy Core")
+ ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
+ ppr CoreDesugar = ptext (sLit "Desugar")
+ ppr CoreTidy = ptext (sLit "Tidy Core")
ppr CorePrep = ptext (sLit "CorePrep")
ppr CoreDoPrintCore = ptext (sLit "Print core")
ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
simpl_phase phase names iter
= CoreDoPasses
- [ maybe_strictness_before phase
+ $ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
- , maybe_rule_check (Phase phase)
- ]
+ , maybe_rule_check (Phase phase) ]
- vectorisation
- = runWhen (dopt Opt_Vectorise dflags)
- $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
+ -- Vectorisation can introduce a fair few common sub expressions involving
+ -- DPH primitives. For example, see the Reverse test from dph-examples.
+ -- We need to eliminate these common sub expressions before their definitions
+ -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
+ -- so we also run simpl_gently to inline them.
+ ++ (if dopt Opt_Vectorise dflags && phase == 3
+ then [CoreCSE, simpl_gently]
+ else [])
+ vectorisation
+ = runWhen (dopt Opt_Vectorise dflags) $
+ CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
-- By default, we have 2 phases before phase 0.
simpl_gently = CoreDoSimplify max_iter
(base_mode { sm_phase = InitialPhase
, sm_names = ["Gentle"]
- , sm_rules = True -- Note [RULEs enabled in SimplGently]
+ , sm_rules = rules_on -- Note [RULEs enabled in SimplGently]
, sm_inline = False
, sm_case_case = False })
-- Don't do case-of-case transformations.
But watch out: list fusion can prevent floating. So use phase control
to switch off those rules until after floating.
-Currently (Oct10) I think that sm_rules is always True, so we
-could remove it.
-
%************************************************************************
%* *
liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
#endif
\end{code}
+
+\begin{code}
+updNameCache' :: (NameCache -> (NameCache, a)) -> CoreM a
+updNameCache' upd_fn = do
+ HscEnv { hsc_NC = nc_var } <- getHscEnv
+ r <- liftIO $ atomicModifyIORef nc_var upd_fn
+ r' <- liftIO $ readIORef nc_var
+ _ <- liftIO $ evaluate r'
+ return r
+
+-- cut-and-pasted from IfaceEnv, where it lives in the TcRn monad rather than CoreM
+lookupOrigCoreM :: Module -> OccName -> CoreM Name
+lookupOrigCoreM mod occ
+ = do { mod `seq` occ `seq` return ()
+ ; updNameCache' $ \name_cache ->
+ case lookupOrigNameCache (nsNames name_cache) mod occ of {
+ Just name -> (name_cache, name);
+ Nothing ->
+ case takeUniqFromSupply (nsUniqs name_cache) of {
+ (uniq, us) ->
+ let
+ name = mkExternalName uniq mod occ noSrcSpan
+ new_cache = extendNameCache (nsNames name_cache) mod occ name
+ in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
+ }}}
+\end{code}
\ No newline at end of file