X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=64f3498ad422aa5c8e76584d091a51b3f4366669;hb=90b9566607ef837329434657c8fabc4bdffdf1af;hp=1f65d212e67aac414c0f64341e31250fc8c683ce;hpb=e517644d3a3272f4306654d0f50db28c664a9a8b;p=ghc-hetmet.git

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 1f65d21..64f3498 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -20,7 +20,7 @@ import CoreLint
 import CoreUtils
 import VarEnv
 import VarSet
-import Var
+import Var hiding( mkGlobalId )
 import Id
 import IdInfo
 import InstEnv
@@ -34,21 +34,17 @@ import OccName
 import TcType
 import DataCon
 import TyCon
-import Class
 import Module
 import HscTypes
 import Maybes
 import ErrUtils
 import UniqSupply
 import Outputable
-import FastTypes hiding (fastOr)
+import FastBool hiding ( fastOr )
 
 import Data.List	( partition )
 import Data.Maybe	( isJust )
 import Data.IORef	( IORef, readIORef, writeIORef )
-
-_dummy :: FS.FastString
-_dummy = FSLIT("")
 \end{code}
 
 
@@ -306,12 +302,10 @@ tidyProgram hsc_env
 		-- and indeed it does, but if omit_prags is on, ext_rules is
 		-- empty
 
-	      ; implicit_binds = getImplicitBinds type_env
-	      ; all_tidy_binds = implicit_binds ++ tidy_binds
 	      ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
 	      }
 
-   	; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
+   	; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
 	; dumpIfSet_core dflags Opt_D_dump_simpl
 		"Tidy Core Rules"
 		(pprRules tidy_rules)
@@ -320,7 +314,7 @@ tidyProgram hsc_env
 
 	; return (CgGuts { cg_module   = mod, 
 			   cg_tycons   = alg_tycons,
-			   cg_binds    = all_tidy_binds,
+			   cg_binds    = tidy_binds,
 			   cg_dir_imps = dir_imp_mods,
 			   cg_foreign  = foreign_stubs,
 			   cg_dep_pkgs = dep_pkgs deps,
@@ -403,13 +397,14 @@ mustExposeTyCon exports tc
   | isEnumerationTyCon tc	-- For an enumeration, exposing the constructors
   = True			-- won't lead to the need for further exposure
 				-- (This includes data types with no constructors.)
-  | isOpenTyCon tc		-- open type family
+  | isOpenTyCon tc		-- Open type family
   = True
+
   | otherwise			-- Newtype, datatype
   = any exported_con (tyConDataCons tc)
 	-- Expose rep if any datacon or field is exported
 
-  || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
+  || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc)))
 	-- Expose the rep for newtypes if the rep is an FFI type.  
 	-- For a very annoying reason.  'Foreign import' is meant to
 	-- be able to look through newtypes transparently, but it
@@ -424,31 +419,6 @@ tidyInstances tidy_dfun ispecs
   where
     tidy ispec = setInstanceDFunId ispec $
 		 tidy_dfun (instanceDFunId ispec)
-
-getImplicitBinds :: TypeEnv -> [CoreBind]
-getImplicitBinds type_env
-  = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
-		  ++ concatMap other_implicit_ids (typeEnvElts type_env))
-	-- Put the constructor wrappers first, because
-	-- other implicit bindings (notably the fromT functions arising 
-	-- from generics) use the constructor wrappers.  At least that's
-	-- what External Core likes
-  where
-    implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-    
-    other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
-	-- The "naughty" ones are not real functions at all
-	-- They are there just so we can get decent error messages
-	-- See Note  [Naughty record selectors] in MkId.lhs
-    other_implicit_ids (AClass cl) = classSelIds cl
-    other_implicit_ids _other      = []
-    
-    get_defn :: Id -> CoreBind
-    get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs)
-	where
-	  rhs = unfoldingTemplate (idUnfolding id)
-	-- Don't forget to tidy the body !  Otherwise you get silly things like
-	--	\ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
 \end{code}
 
 
@@ -743,12 +713,13 @@ tidyTopPair :: VarEnv Bool
 	-- in the IdInfo of one early in the group
 
 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
-  | isGlobalId bndr 		-- Injected binding for record selector, etc
-  = (bndr, tidyExpr rhs_tidy_env rhs)
-  | otherwise
   = (bndr', rhs')
   where
-    bndr'   = mkVanillaGlobal name' ty' idinfo'
+    bndr' = mkGlobalId details name' ty' idinfo'
+	-- Preserve the GlobalIdDetails of existing global-ids
+    details = case globalIdDetails bndr of	
+		NotGlobalId -> VanillaGlobal
+		old_details -> old_details
     ty'	    = tidyTopType (idType bndr)
     rhs'    = tidyExpr rhs_tidy_env rhs
     idinfo  = idInfo bndr
@@ -817,7 +788,7 @@ tidyWorker _tidy_env _show_unfold NoWorker
   = NoWorker
 tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) 
   | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
-  | otherwise   = WARN( True, ppr work_id ) NoWorker
+  | otherwise   = NoWorker
     -- 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
@@ -825,8 +796,12 @@ tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
     -- then you can make the simplifier go into an infinite loop, because
     -- in effect the unfolding is exposed.  See Trac #1709
     -- 
-    -- Mind you, it probably should not be w/w'd in the first place; 
-    -- hence the WARN
+    -- You might think that if show_unfold is False, then the thing should
+    -- not be w/w'd in the first place.  But a legitimate reason is this:
+    -- 	  the function returns bottom
+    -- In this case, show_unfold will be false (we don't expose unfoldings
+    -- for bottoming functions), but we might still have a worker/wrapper
+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs
 \end{code}
 
 %************************************************************************