X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=67a0991ec0b43d7518ee46e6776b78b626637b99;hp=0b8ea1e4a1e5e812a0bb6bdd3a2a3c314b5ac41c;hb=5909e9a896d40a18b4bcf6abb95e0b071bfd7db2;hpb=c177e43f99dcd525b78ee0ac8f16c3d42c618e1f

diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 0b8ea1e..67a0991 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -43,6 +43,8 @@ module CoreMonad (
     debugTraceMsg, debugTraceMsgS,
     dumpIfSet_dyn, 
 
+    lookupOrigCoreM,
+
 #ifdef GHCI
     -- * Getting 'Name's
     thNameToGhcName
@@ -58,7 +60,7 @@ import CoreUtils
 import CoreLint		( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes
-import Module           ( PackageId, Module )
+import Module           ( Module )
 import DynFlags
 import StaticFlags	
 import Rules            ( RuleBase )
@@ -90,6 +92,11 @@ import Data.Word
 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 )
@@ -219,7 +226,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | 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
 
@@ -240,10 +247,10 @@ coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 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
@@ -264,9 +271,9 @@ instance Outputable CoreToDo where
   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")
@@ -370,18 +377,25 @@ getCoreToDo dflags
 
     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.
 
@@ -402,7 +416,7 @@ getCoreToDo dflags
     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.
@@ -569,9 +583,6 @@ RULES are enabled when doing "gentle" simplification.  Two reasons:
 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.
-
 
 %************************************************************************
 %*									*
@@ -1117,3 +1128,29 @@ thNameToGhcName th_name = do
     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