From 1703fe03e209e9d1f11c19a2b05fd4f0fd3d28f0 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 20 Feb 2001 15:44:26 +0000 Subject: [PATCH] [project @ 2001-02-20 15:44:26 by simonpj] Eta expansion wibbles ~~~~~~~~~~~~~~~~~~~~~ * Don't eta reduce, and do eta expand, data con workers and primops Reason: they don't have bindings, so they aren't really ordinary variables. This is a bit of a swamp, provoked by moving CoreSat later, something I'm beginning to wonder about... Not are things settled yet -- I think some rules may not fire that should because of constructor worker/wrapper issues. E.g when you have foldr (:) [] xs = xs --- ghc/compiler/coreSyn/CoreUtils.lhs | 16 +++++++++++++--- ghc/compiler/main/DriverFlags.hs | 3 ++- ghc/compiler/main/DriverState.hs | 6 +++++- ghc/compiler/simplCore/Simplify.lhs | 20 ++++++++++++-------- 4 files changed, 32 insertions(+), 13 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index baae2ba..f0649d1 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -44,13 +44,13 @@ import Var ( Var, isId, isTyVar ) import VarSet import VarEnv import Name ( hashName ) -import Literal ( hashLiteral, literalType, litSize, litIsDupable ) +import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) import PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable ) import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, - isDataConId_maybe, isPrimOpId_maybe, mkSysLocal + isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding ) import IdInfo ( LBVarInfo(..), IdFlavour(..), @@ -258,7 +258,17 @@ mkIfThenElse guard then_expr else_expr \begin{code} exprIsTrivial (Var v) - | Just op <- isPrimOpId_maybe v = primOpIsDupable op + | hasNoBinding v = idArity v == 0 + -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op + -- The idea here is that a constructor worker, like $wJust, is + -- really short for (\x -> $wJust x), becuase $wJust has no binding. + -- So it should be treated like a lambda. + -- Ditto unsaturated primops. + -- This came up when dealing with eta expansion/reduction for + -- x = $wJust + -- Here we want to eta-expand. This looks like an optimisation, + -- but it's important (albeit tiresome) that CoreSat doesn't increase + -- anything's arity | otherwise = True exprIsTrivial (Type _) = True exprIsTrivial (Lit lit) = True diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index f9ff637..10268aa 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.44 2001/02/20 11:04:42 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.45 2001/02/20 15:44:26 simonpj Exp $ -- -- Driver flags -- @@ -408,6 +408,7 @@ dynamic_flags = [ , ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) ) , ( "dshow-passes", NoArg (setVerbosity "2") ) , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) ) + , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) , ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) ) , ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) ) diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 36ac74b..42b0be1 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.27 2001/02/20 11:04:42 simonmar Exp $ +-- $Id: DriverState.hs,v 1.28 2001/02/20 15:44:26 simonpj Exp $ -- -- Settings for the driver -- @@ -144,6 +144,10 @@ hsc_minusNoO_flags = [ "-fignore-interface-pragmas", "-fomit-interface-pragmas", + "-fdo-lambda-eta-expansion", -- This one is important for a tiresome reason: + -- we want to make sure that the bindings for data + -- constructors are eta-expanded. This is probably + -- a good thing anyway, but it seems fragile. "-flet-no-escape" ] diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 56466cb..c766c8f 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -22,11 +22,10 @@ import SimplUtils ( mkCase, tryRhsTyLam, tryEtaExpansion, findAlt, ) import Var ( mkSysTyVar, tyVarKind ) import VarEnv -import VarSet ( elemVarSet ) -import Id ( Id, idType, idInfo, isDataConId, +import Id ( Id, idType, idInfo, isDataConId, hasNoBinding, idUnfolding, setIdUnfolding, isExportedId, isDeadBinder, idDemandInfo, setIdInfo, - idOccInfo, setIdOccInfo, + idOccInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, @@ -40,7 +39,7 @@ import DataCon ( dataConNumInstArgs, dataConRepStrictness, ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreFVs ( mustHaveLocalBinding, exprFreeVars ) +import CoreFVs ( mustHaveLocalBinding ) import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) @@ -364,8 +363,12 @@ completeLam rev_bndrs body cont Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont where -- We don't use CoreUtils.etaReduce, because we can be more - -- efficient here: (a) we already have the binders, (b) we can do - -- the triviality test before computing the free vars + -- efficient here: + -- (a) we already have the binders, + -- (b) we can do the triviality test before computing the free vars + -- [in fact I take the simple path and look for just a variable] + -- (c) we don't want to eta-reduce a data con worker or primop + -- because we only have to eta-expand them later when we saturate try_eta body | not opt_SimplDoEtaReduction = Nothing | otherwise = go rev_bndrs body @@ -373,8 +376,9 @@ completeLam rev_bndrs body cont go [] body | ok_body body = Just body -- Success! go _ _ = Nothing -- Failure! - ok_body body = exprIsTrivial body && not (any (`elemVarSet` exprFreeVars body) rev_bndrs) - ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg + ok_body (Var v) = not (v `elem` rev_bndrs) && not (hasNoBinding v) + ok_body other = False + ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg mkLamBndrZapper :: CoreExpr -- Function -> SimplCont -- The context -- 1.7.10.4