diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index f571658ec54ba2b32e79307da961c1b2d52d4fdc..9b9a5ad5931d41b902ba635148156bea21e9505c 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -1,4 +1,4 @@
-%
+`%
% (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
diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 787d1688e2582b10a0c8dc9845c07a051249dbcb..df9572751b96eb57c53c20739aeb2658e4f928b3 100644
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/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)