X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=a7671a42443626e517c1061be75a0187e8c6321f;hb=5952ef0dfd1a9eec38bd2756b37d040feb2b09d8;hp=844c401ce83cd4cd078c83e2b7182b3e3f2d5aaf;hpb=ca919ae01e81fb4afb2243bb34eceff56ca66043;p=ghc-hetmet.git

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 844c401..a7671a4 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -19,9 +19,7 @@ import DynFlags		( CoreToDo(..), SimplifierSwitch(..),
 			  SimplifierMode(..), DynFlags, DynFlag(..), dopt,
 			  getCoreToDo )
 import CoreSyn
-import HscTypes		( HscEnv(..), ModGuts(..), ExternalPackageState(..),
-			  Dependencies( dep_mods ), 
-			  hscEPS, hptRules )
+import HscTypes
 import CSE		( cseProgram )
 import Rules		( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
 			  extendRuleBaseList, pprRuleBase, ruleCheckProgram,
@@ -41,8 +39,10 @@ import CoreLint		( endPass, endIteration )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FamInstEnv
-import Id		( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
-			  idSpecialisation, idName )
+import Id
+import DataCon
+import TyCon		( tyConSelIds, tyConDataCons )
+import Class		( classSelIds )
 import VarSet
 import VarEnv
 import NameEnv		( lookupNameEnv )
@@ -62,7 +62,7 @@ import UniqSupply	( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import IO		( hPutStr, stderr )
 import Outputable
 import List		( partition )
-import Maybes		( orElse )
+import Maybes
 \end{code}
 
 %************************************************************************
@@ -77,26 +77,30 @@ core2core :: HscEnv
 	  -> IO ModGuts
 
 core2core hsc_env guts
-  = do
-        let dflags = hsc_dflags hsc_env
-	    core_todos = getCoreToDo dflags
+  = do	{
+	; let dflags = hsc_dflags hsc_env
+	      core_todos = getCoreToDo dflags
 
-	us <- mkSplitUniqSupply 's'
-	let (cp_us, ru_us) = splitUniqSupply us
+	; us <- mkSplitUniqSupply 's'
+	; let (cp_us, ru_us) = splitUniqSupply us
 
 		-- COMPUTE THE RULE BASE TO USE
-	(imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
+	; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+
+		-- Note [Injecting implicit bindings]
+        ; let implicit_binds = getImplicitBinds (mg_types guts1)
+	      guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
 
 		-- DO THE BUSINESS
-	(stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
-			 		(zeroSimplCount dflags) 
-					guts' core_todos
+	; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
+			 		 (zeroSimplCount dflags) 
+				 	 guts2 core_todos
 
-	dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+	; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
 		  "Grand total simplifier statistics"
 		  (pprSimplCount stats)
 
-	return guts''
+	; return guts3 }
 
 
 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
@@ -157,7 +161,7 @@ doCorePass CoreDoSpecConstr	       = {-# SCC "SpecConstr" #-}    trBindsU specCo
 doCorePass CoreDoGlomBinds	       = trBinds glomBinds
 doCorePass CoreDoVectorisation         = {-# SCC "Vectorise" #-}     vectorise
 doCorePass CoreDoPrintCore	       = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
+doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
 doCorePass CoreDoNothing	       = observe (\ _ _ -> return ())
 #ifdef OLD_STRICTNESS		       
 doCorePass CoreDoOldStrictness	       = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
@@ -175,8 +179,11 @@ doOldStrictness dfs binds
 
 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
 
-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
-				      printDump (ruleCheckProgram phase pat binds)
+ruleCheck phase pat hsc_env us rb guts 
+  =  do let dflags = hsc_dflags hsc_env
+	showPass dflags "RuleCheck"
+        printDump (ruleCheckProgram phase pat rb (mg_binds guts))
+	return (zeroSimplCount dflags, guts)
 
 -- Most passes return no stats and don't change rules
 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
@@ -209,10 +216,51 @@ observe do_pass hsc_env us rb guts
 \end{code}
 
 
+%************************************************************************
+%*									*
+	Implicit bindings
+%*									*
+%************************************************************************
+
+Note [Injecting implicit bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to inject the implict bindings right at the end, in CoreTidy.
+But some of these bindings, notably record selectors, are not
+constructed in an optimised form.  E.g. record selector for
+	data T = MkT { x :: {-# UNPACK #-} !Int }
+Then the unfolding looks like
+	x = \t. case t of MkT x1 -> let x = I# x1 in x
+This generates bad code unless it's first simplified a bit.
+(Only matters when the selector is used curried; eg map x ys.)
+See Trac #2070.
+
+\begin{code}
+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 (unfoldingTemplate (idUnfolding id))
+\end{code}
+
 
 %************************************************************************
 %*									*
-\subsection{Dealing with rules}
+	Dealing with rules
 %*									*
 %************************************************************************
 
@@ -241,7 +289,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
 	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
 	      env	       = setInScopeSet gentleSimplEnv local_ids 
 	      (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-				 (mapSmpl (simplRule env) local_rules)
+				 (mapM (simplRule env) local_rules)
 	      home_pkg_rules   = hptRules hsc_env (dep_mods deps)
 
 		-- Find the rules for locally-defined Ids; then we can attach them
@@ -298,12 +346,12 @@ This doesn't match unless you do eta reduction on the build argument.
 
 \begin{code}
 simplRule env rule@(BuiltinRule {})
-  = returnSmpl rule
+  = return rule
 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
-  = simplBinders env bndrs		`thenSmpl` \ (env, bndrs') -> 
-    mapSmpl (simplExprGently env) args	`thenSmpl` \ args' ->
-    simplExprGently env rhs		`thenSmpl` \ rhs' ->
-    returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
+  = do (env, bndrs') <- simplBinders env bndrs
+       args' <- mapM (simplExprGently env) args
+       rhs' <- simplExprGently env rhs
+       return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
 
 -- It's important that simplExprGently does eta reduction.
 -- For example, in a rule like:
@@ -330,8 +378,8 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
 -- enforce that; it just simplifies the expression twice
 
-simplExprGently env expr
-  = simplExpr env (occurAnalyseExpr expr) 	`thenSmpl` \ expr1 ->
+simplExprGently env expr = do
+    expr1 <- simplExpr env (occurAnalyseExpr expr)
     simplExpr env (occurAnalyseExpr expr1)
 \end{code}