Propagate scalar variables and tycons for vectorisation through 'HscTypes.VectInfo'.

[ghc-hetmet.git] / compiler / main / TidyPgm.lhs

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index a030983..b3f1a06 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -46,6 +46,7 @@ import FastBool hiding ( fastOr )
 import Util
 import FastString
 
+import Control.Monad   ( when )
 import Data.List       ( sortBy )
 import Data.IORef      ( IORef, readIORef, writeIORef )
 \end{code}
@@ -291,8 +292,7 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                                mg_binds = binds, 
                                mg_rules = imp_rules,
                                 mg_vect_info = vect_info,
-                               mg_dir_imps = dir_imps, 
-                               mg_anns = anns,
+                                mg_anns = anns,
                                 mg_deps = deps, 
                                mg_foreign = foreign_stubs,
                                mg_hpc_info = hpc_info,
@@ -353,13 +353,19 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
                     (ptext (sLit "rules"))
                     (pprRulesForUser tidy_rules)
 
-        ; let dir_imp_mods = moduleEnvKeys dir_imps
-
-       ; return (CgGuts { cg_module   = mod, 
-                          cg_tycons   = alg_tycons,
-                          cg_binds    = all_tidy_binds,
-                          cg_dir_imps = dir_imp_mods,
-                          cg_foreign  = foreign_stubs,
+          -- Print one-line size info
+        ; let cs = coreBindsStats tidy_binds
+        ; when (dopt Opt_D_dump_core_stats dflags)
+              (printDump (ptext (sLit "Tidy size (terms,types,coercions)") 
+                           <+> ppr (moduleName mod) <> colon 
+                           <+> int (cs_tm cs) 
+                           <+> int (cs_ty cs) 
+                           <+> int (cs_co cs) ))
+
+        ; return (CgGuts { cg_module   = mod,
+                           cg_tycons   = alg_tycons,
+                           cg_binds    = all_tidy_binds,
+                           cg_foreign  = foreign_stubs,
                           cg_dep_pkgs = dep_pkgs deps,
                           cg_hpc_info = hpc_info,
                            cg_modBreaks = modBreaks }, 
@@ -481,12 +487,16 @@ tidyInstances tidy_dfun ispecs
 
 \begin{code}
 tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
-tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar     = vars
-                                         , vectInfoPADFun  = pas
-                                         , vectInfoIso     = isos })
-  = info { vectInfoVar    = tidy_vars
-         , vectInfoPADFun = tidy_pas
-         , vectInfoIso    = tidy_isos }
+tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
+                                         , vectInfoPADFun       = pas
+                                         , vectInfoIso          = isos
+                                         , vectInfoScalarVars   = scalarVars
+                                         })
+  = info { vectInfoVar          = tidy_vars
+         , vectInfoPADFun       = tidy_pas
+         , vectInfoIso          = tidy_isos 
+         , vectInfoScalarVars   = tidy_scalarVars
+         }
   where
     tidy_vars = mkVarEnv
               $ map tidy_var_mapping
@@ -498,6 +508,10 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar     = vars
     tidy_var_mapping (from, to) = (from', (from', lookup_var to))
       where from' = lookup_var from
     tidy_snd_var (x, var) = (x, lookup_var var)
+
+    tidy_scalarVars = mkVarSet
+                    $ map lookup_var
+                    $ varSetElems scalarVars
       
     lookup_var var = lookupWithDefaultVarEnv var_env var var
 \end{code}
@@ -712,7 +726,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold)
                      CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } 
                                            | show_unfolding src guide
                                            -> Just (unf_ext_ids src unf_rhs)
-                     DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops)
+                      DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
                      _                     -> Nothing
                   where
                     unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
@@ -854,10 +868,9 @@ tidyTopName mod nc_var maybe_ref occ_env id
 
     (occ_env', occ') = tidyOccName occ_env new_occ
 
-    mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
+    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
                    where
-                     (us1, us2) = splitUniqSupply (nsUniqs nc)
-                     uniq       = uniqFromSupply us1
+                     (uniq, us) = takeUniqFromSupply (nsUniqs nc)
 
     mk_new_external nc = allocateGlobalBinder nc mod occ' loc
        -- If we want to externalise a currently-local name, check
@@ -1066,8 +1079,12 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
 
     --------- Unfolding ------------
     unf_info = unfoldingInfo idinfo
-    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
                | otherwise   = noUnfolding
+    unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
+    is_bot = case final_sig of 
+                Just sig -> isBottomingSig sig
+                Nothing  -> False
     -- NB: do *not* expose the worker if show_unfold is off,
     --     because that means this thing is a loop breaker or
     --     marked NOINLINE or something like that
@@ -1090,30 +1107,6 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
     -- it to the top level. So it seems more robust just to
     -- fix it here.
     arity = exprArity orig_rhs
-
-
-
------------- Unfolding  --------------
-tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding ar con ids)
-  = DFunUnfolding ar con (map (tidyExpr tidy_env) ids)
-tidyUnfolding tidy_env tidy_rhs strict_sig
-              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
-  | isStableSource src
-  = unf { uf_tmpl = tidyExpr tidy_env unf_rhs,            -- Preserves OccInfo
-         uf_src  = tidyInl tidy_env src }
-  | otherwise
-  = mkTopUnfolding is_bot tidy_rhs
-  where
-    is_bot = case strict_sig of 
-                Just sig -> isBottomingSig sig
-                Nothing  -> False
-
-tidyUnfolding _ _ _ unf = unf
-
-tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource
-tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
-tidyInl _        inl_info          = inl_info
 \end{code}
 
 %************************************************************************
@@ -1171,6 +1164,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts
 cafRefs p (Note _n e)         = cafRefs p e
 cafRefs p (Cast e _co)         = cafRefs p e
 cafRefs _ (Type _)            = fastBool False
+cafRefs _ (Coercion _)         = fastBool False
 
 cafRefss :: VarEnv Id -> [Expr a] -> FastBool
 cafRefss _ []    = fastBool False