[project @ 1997-05-18 23:40:29 by sof]

2.04 updates

ghc/compiler/simplCore/SimplCase.lhs

-%
+`%
 % (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[SimplCase]{Simplification of `case' expression}
@@ -18,10 +18,11 @@ import CmdLineOpts	( SimplifierSwitch(..) )
 import CoreSyn
 import CoreUnfold	( Unfolding, SimpleUnfolding )
 import CoreUtils	( coreAltsType, nonErrorRHSs, maybeErrorApp,
-			  unTagBindersAlts
+			  unTagBindersAlts, unTagBinders, coreExprType
 			)
 import Id		( idType, isDataCon, getIdDemandInfo,
-			  SYN_IE(DataCon), GenId{-instance Eq-}
+			  SYN_IE(DataCon), GenId{-instance Eq-},
+			  SYN_IE(Id)
 			)
 import IdInfo		( willBeDemanded, DemandInfo )
 import Literal		( isNoRepLit, Literal{-instance Eq-} )
@@ -34,7 +35,8 @@ import Type		( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqT
 import TysPrim		( voidTy )
 import Unique		( Unique{-instance Eq-} )
 import Usage		( GenUsage{-instance Eq-} )
-import Util		( isIn, isSingleton, zipEqual, panic, assertPanic )
+import Util		( SYN_IE(Eager), runEager, appEager,
+			  isIn, isSingleton, zipEqual, panic, assertPanic )
 \end{code}
 
 Float let out of case.
@@ -44,7 +46,7 @@ simplCase :: SimplEnv
 	  -> InExpr	-- Scrutinee
 	  -> InAlts	-- Alternatives
 	  -> (SimplEnv -> InExpr -> SmplM OutExpr)	-- Rhs handler
-	  -> OutType				-- Type of result expression
+	  -> OutType					-- Type of result expression
 	  -> SmplM OutExpr
 
 simplCase env (Let bind body) alts rhs_c result_ty
@@ -109,7 +111,7 @@ simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
     else
 	bindLargeAlts env outer_alts rhs_c result_ty	`thenSmpl` \ (extra_bindings, outer_alts') ->
 	let
-	   rhs_c' = \env rhs -> simplExpr env rhs []
+	   rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
 	in
 	simplCase env inner_scrut inner_alts
 		  (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
@@ -129,10 +131,9 @@ simplCase env scrut alts rhs_c result_ty
   | maybeToBool maybe_error_app
   = 	-- Look for an application of an error id
     tick CaseOfError 	`thenSmpl_`
-    rhs_c env retyped_error_app
+    returnSmpl retyped_error_app
   where
-    alts_ty 	    	   = coreAltsType (unTagBindersAlts alts)
-    maybe_error_app 	   = maybeErrorApp scrut (Just alts_ty)
+    maybe_error_app 	   = maybeErrorApp scrut (Just result_ty)
     Just retyped_error_app = maybe_error_app
 \end{code}
 
@@ -140,9 +141,18 @@ Finally the default case
 
 \begin{code}
 simplCase env other_scrut alts rhs_c result_ty
-  = 	-- Float the let outside the case scrutinee
-    simplExpr env other_scrut []	`thenSmpl` \ scrut' ->
+  = simplTy env scrut_ty			`appEager` \ scrut_ty' ->
+    simplExpr env' other_scrut [] scrut_ty	`thenSmpl` \ scrut' ->
     completeCase env scrut' alts rhs_c
+  where
+	-- When simplifying the scrutinee of a complete case that
+	-- has no default alternative
+    env' = case alts of
+		AlgAlts _ NoDefault  -> setCaseScrutinee env
+		PrimAlts _ NoDefault -> setCaseScrutinee env
+		other		     -> env
+
+    scrut_ty = coreExprType (unTagBinders other_scrut)
 \end{code}
 
 
@@ -355,7 +365,7 @@ completeCase env scrut alts rhs_c
 	-- the scrutinee.  Remember that the rhs is as yet unsimplified.
     rhs1_is_scrutinee = case (scrut, rhs1) of
 			  (Var scrut_var, Var rhs_var)
-				-> case lookupId env rhs_var of
+				-> case (runEager $ lookupId env rhs_var) of
 				    VarArg rhs_var' -> rhs_var' == scrut_var
 				    other	    -> False
 			  other -> False
@@ -440,14 +450,16 @@ bindLargeRhs env args rhs_ty rhs_c
 		App (Var prim_rhs_fun_id) (VarArg voidId))
 
   | otherwise
-  = 	-- Make the new binding Id.  NB: it's an OutId
-    newId rhs_fun_ty 		`thenSmpl` \ rhs_fun_id ->
-
-	-- Generate its rhs
+  =	-- Generate the rhs
     cloneIds env used_args	`thenSmpl` \ used_args' ->
     let
 	new_env = extendIdEnvWithClones env used_args used_args'
+	rhs_fun_ty :: OutType
+	rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
     in
+
+	-- Make the new binding Id.  NB: it's an OutId
+    newId rhs_fun_ty 		`thenSmpl` \ rhs_fun_id ->
     rhs_c new_env		`thenSmpl` \ rhs' ->
     let
 	final_rhs = mkValLam used_args' rhs'
@@ -459,8 +471,6 @@ bindLargeRhs env args rhs_ty rhs_c
 	-- it's processed the OutId won't be found in the environment, so it
 	-- will be left unmodified.
   where
-    rhs_fun_ty :: OutType
-    rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
 
     used_args      = [arg | arg@(_,usage) <- args, not (dead usage)]
     used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
@@ -505,8 +515,7 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c
 	    new_env = case scrut of
 		       Var v -> extendEnvGivenNewRhs env1 v (Con con args)
 			     where
-				(_, ty_args, _) = --trace "SimplCase.getAppData..." $
-						  getAppDataTyConExpandingDicts (idType v)
+				(_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
 				args = map TyArg ty_args ++ map VarArg con_args'
 
 		       other -> env1

ghc/compiler/simplCore/SimplCore.lhs

@@ -27,7 +27,7 @@ import CmdLineOpts	( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
 import CoreLint		( lintCoreBindings )
 import CoreSyn
 import CoreUtils	( coreExprType )
-import SimplUtils	( etaCoreExpr )
+import SimplUtils	( etaCoreExpr, typeOkForCase )
 import CoreUnfold
 import Literal		( Literal(..), literalType, mkMachInt )
 import ErrUtils		( ghcExit )
@@ -35,19 +35,20 @@ import FiniteMap	( FiniteMap )
 import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FoldrBuildWW	( mkFoldrBuildWW )
-import Id		( mkSysLocal, setIdVisibility,
+import Id		( mkSysLocal, setIdVisibility, mkIdWithNewName, getIdDemandInfo, idType,
 			  nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
- 			  lookupIdEnv, SYN_IE(IdEnv),
-			  GenId{-instance Outputable-}
+ 			  lookupIdEnv, SYN_IE(IdEnv), omitIfaceSigForId,
+			  GenId{-instance Outputable-}, SYN_IE(Id)
 			)
-import Name		( isExported, isLocallyDefined )
+import IdInfo		( willBeDemanded, DemandInfo )
+import Name		( isExported, isLocallyDefined, SYN_IE(Module), NamedThing(..) )
 import TyCon		( TyCon )
 import PrimOp		( PrimOp(..) )
 import PrelVals		( unpackCStringId, unpackCString2Id,
 			  integerZeroId, integerPlusOneId,
 			  integerPlusTwoId, integerMinusOneId
 			)
-import Type		( maybeAppDataTyCon, getAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts )
+import Type		( maybeAppDataTyCon, isPrimType, SYN_IE(Type) )
 import TysWiredIn	( stringTy )
 import LiberateCase	( liberateCase )
 import MagicUFs		( MagicUnfoldingFun )
@@ -55,7 +56,7 @@ import Outputable	( Outputable(..){-instance * (,) -} )
 import PprCore
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
-import Pretty		( ppShow, ppAboves, ppAbove, ppCat )
+import Pretty		( Doc, vcat, ($$), hsep )
 import SAT		( doStaticArgs )
 import SimplMonad	( zeroSimplCount, showSimplCount, SimplCount )
 import SimplPgm		( simplifyPgm )
@@ -64,7 +65,8 @@ import SpecUtils	( pprSpecErrs )
 import StrictAnal	( saWwTopBinds )
 import TyVar		( nullTyVarEnv, GenTyVar{-instance Eq-} )
 import Unique		( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
-import UniqSupply	( splitUniqSupply, getUnique )
+import UniqFM           ( Uniquable(..) )
+import UniqSupply	( splitUniqSupply, getUnique, UniqSupply )
 import Util		( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
 import SrcLoc		( noSrcLoc )
 import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
@@ -207,7 +209,7 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 		   -- if we got errors, we die straight away
 		   (if not spec_noerrs ||
 		       (opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
-			hPutStr stderr (ppShow 1000 {-pprCols-}
+			hPutStr stderr (show
 			    (pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
 			>> hPutStr stderr "\n"
 		    else
@@ -250,8 +252,8 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
 	 then
 	    hPutStr stderr ("\n*** "++what++":\n")
 		>>
-	    hPutStr stderr (ppShow 1000
-		(ppAboves (map (pprCoreBinding ppr_style) binds2)))
+	    hPutStr stderr (show
+		(vcat (map (pprCoreBinding ppr_style) binds2)))
 		>>
 	    hPutStr stderr "\n"
 	 else
@@ -324,6 +326,9 @@ Several tasks are done by @tidyCorePgm@
 	nuke them if possible.   (In general the simplifier does eta expansion not
 	eta reduction, up to this point.)
 
+8.	Do let-to-case.  See notes in Simplify.lhs for why we defer let-to-case
+	for multi-constructor types.
+
 
 Eliminate indirections
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -383,15 +388,48 @@ tidyCorePgm mod us binds_in
     (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 
     try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
-    try_bind env_so_far
-	     (NonRec exported_binder (Var local_id))
+    try_bind env_so_far (NonRec exported_binder rhs)
 	| isExported exported_binder &&		-- Only if this is exported
-	  isLocallyDefined local_id &&		-- Only if this one is defined in this
-	  not (isExported local_id) &&		-- 	module, so that we *can* change its
+	  maybeToBool maybe_rhs_id &&		-- 	and the RHS is a simple Id
+
+	  isLocallyDefined rhs_id &&		-- Only if this one is defined in this
+	  					-- 	module, so that we *can* change its
 					  	-- 	binding to be the exported thing!
-	  not (maybeToBool (lookupIdEnv env_so_far local_id))
+
+	  not (isExported rhs_id) &&		-- Only if this one is not itself exported,
+						--	since the transformation will nuke it
+
+	  not (omitIfaceSigForId rhs_id) &&	-- Don't do the transformation if rhs_id is
+						-- 	something like a constructor, whose 
+						--	definition is implicitly exported and 
+						-- 	which must not vanish.
+		-- To illustrate the preceding check consider
+		--	data T = MkT Int
+		--	mkT = MkT
+		--	f x = MkT (x+1)
+		-- Here, we'll make a local, non-exported, defn for MkT, and without the
+		-- above condition we'll transform it to:
+		--	mkT = \x. MkT [x]
+		--	f = \y. mkT (y+1)
+		-- This is bad because mkT will get the IdDetails of MkT, and won't
+		-- be exported.  Also the code generator won't make a definition for
+		-- the MkT constructor.
+		-- Slightly gruesome, this.
+
+	  not (maybeToBool (lookupIdEnv env_so_far rhs_id))
 						-- Only if not already substituted for
-	= (addOneToIdEnv env_so_far local_id exported_binder, Nothing)
+
+	= (addOneToIdEnv env_so_far rhs_id new_rhs_id, Nothing)
+	where
+	   maybe_rhs_id = case etaCoreExpr rhs of
+				Var rhs_id -> Just rhs_id
+				other	   -> Nothing
+	   Just rhs_id  = maybe_rhs_id
+	   new_rhs_id   = mkIdWithNewName rhs_id (getName exported_binder)
+				-- NB: we keep the Pragmas and IdInfo for the old rhs_id!
+				-- This is important; it might be marked "no-inline" by
+				-- the occurrence analyser (because it's recursive), and
+				-- we must not lose that information.
 
     try_bind env_so_far bind
 	= (env_so_far, Just bind)
@@ -469,6 +507,14 @@ tidyCoreExpr (Lam bndr body)
   = tidyCoreExpr body		`thenTM` \ body' ->
     returnTM (Lam bndr body')
 
+	-- Try for let-to-case (see notes in Simplify.lhs for why
+	-- some let-to-case stuff is deferred to now).
+tidyCoreExpr (Let (NonRec bndr rhs) body)
+  | willBeDemanded (getIdDemandInfo bndr) && 
+    typeOkForCase (idType bndr)
+  = ASSERT( not (isPrimType (idType bndr)) )
+    tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
+
 tidyCoreExpr (Let bind body)
   = tidyCoreBinding bind	`thenTM` \ bind' ->
     tidyCoreExprEta body	`thenTM` \ body' ->
@@ -491,7 +537,7 @@ tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
 
 -- Eliminate polymorphic case, for which we can't generate code just yet
 tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
-  | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut)))
+  | not (typeOkForCase (idType deflt_bndr))
   = pprTrace "Warning: discarding polymorphic case:" (ppr PprDebug scrut) $
     case scrut of
 	Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)