X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=b3f1a062273201154972ac63aee90a717e3ed5c7;hp=8025f20bf17e404a5f43e81c271422c353c29c8f;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=14a496fd0b3aa821b69eb02736d5f41086576761

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 8025f20..b3f1a06 100644
--- 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])
@@ -1065,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
@@ -1089,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}
 
 %************************************************************************
@@ -1170,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