Commit a47b62cb authored by Simon Marlow's avatar Simon Marlow

Second attempt to fix sizeExpr

Summary:
Background:
* sizeExpr was calculating expressions like ((e `cast` T) x) wrongly
* Fixing it caused regressions in compile performance, and one nofib
  program (k-nucleotide)

I managed to fix the source of the compiler regressions.  I think it was
due to traceTc not being inlined, which I fixed in a more robust way by
putting an export list on TcRnMonad.

The k-nucleotide regression is more difficult.  I don't think anything
is actually going wrong, but this program has been highly tuned and is
quite sensitive to changing in inlining behaviour.  I managed to recover
most of the performance by manual lambda-lifting which makes it a bit
less fragile, but the end result was a bit slower.  I don't think this
is disastrous, the program is pretty horrible to begin with and we could
probably make a faster one by starting from scratch.

Test Plan: validate, nofib

Reviewers: simonpj, bgamari, niteria, austin, erikd

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2338

GHC Trac Issues: #11564
parent 12306294
......@@ -513,29 +513,41 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
(size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation
pairs
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
= alts_size (foldr addAltSize sizeZero alt_sizes)
size_up (Case e _ _ alts)
| Just v <- is_top_arg e -- We are scrutinising an argument variable
= let
alt_sizes = map size_up_alt alts
-- alts_size tries to compute a good discount for
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut)
-- Size of all alternatives
(SizeIs max _ _)
-- Size of biggest alternative
= SizeIs tot (unitBag (v, 20 + tot - max)
`unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a
-- discount that will take us back to 'max',
-- the size of the largest alternative The
-- 1+ is a little discount for reduced
-- allocation in the caller
--
-- Notice though, that we return tot_disc,
-- the total discount from all branches. I
-- think that's right.
alts_size tot_size _ = tot_size
in
alts_size (foldr addAltSize sizeZero alt_sizes)
(foldr maxSize sizeZero alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
where
alt_sizes = map size_up_alt alts
-- alts_size tries to compute a good discount for
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
(SizeIs max _ _) -- Size of biggest alternative
= SizeIs tot (unitBag (v, 20 + tot - max) `unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
--
-- Notice though, that we return tot_disc, the total discount from
-- all branches. I think that's right.
alts_size tot_size _ = tot_size
is_top_arg (Var v) | v `elem` top_args = Just v
is_top_arg (Cast e _) = is_top_arg e
is_top_arg _ = Nothing
size_up (Case e _ _ alts) = size_up e `addSizeNSD`
foldr (addAltSize . size_up_alt) case_size alts
......@@ -582,13 +594,18 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
size_up_app fun (arg:args) voids
size_up_app (Var fun) args voids = size_up_call fun args voids
size_up_app (Tick _ expr) args voids = size_up_app expr args voids
size_up_app other args voids = size_up other `addSizeN` (length args - voids)
size_up_app (Cast expr _) args voids = size_up_app expr args voids
size_up_app other args voids = size_up other `addSizeN`
callSize (length args) voids
-- if the lhs is not an App or a Var, or an invisible thing like a
-- Tick or Cast, then we should charge for a complete call plus the
-- size of the lhs itself.
------------
size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
size_up_call fun val_args voids
= case idDetails fun of
FCallId _ -> sizeN (10 * (1 + length val_args))
FCallId _ -> sizeN (callSize (length val_args) voids)
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op -> primOpSize op (length val_args)
ClassOpId _ -> classOpSize dflags top_args val_args
......@@ -661,6 +678,13 @@ classOpSize dflags top_args (arg1 : other_args)
-> unitBag (dict, ufDictDiscount dflags)
_other -> emptyBag
-- | The size of a function call
callSize
:: Int -- ^ number of value args
-> Int -- ^ number of value args that are void
-> Int
callSize n_val_args voids = 10 * (1 + n_val_args - voids)
funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
-- Size for functions that are not constructors or primops
-- Note [Function applications]
......@@ -671,7 +695,7 @@ funSize dflags top_args fun n_val_args voids
where
some_val_args = n_val_args > 0
size | some_val_args = 10 * (1 + n_val_args - voids)
size | some_val_args = callSize n_val_args voids
| otherwise = 0
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
......
......@@ -9,9 +9,124 @@ Functions for working with the typechecker environment (setters, getters...).
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcRnMonad(
module TcRnMonad,
module TcRnTypes,
module IOEnv
-- * Initalisation
initTc, initTcInteractive, initTcForLookup, initTcRnIf,
-- * Simple accessors
discardResult,
getTopEnv, updTopEnv, getGblEnv, updGblEnv,
setGblEnv, getLclEnv, updLclEnv, setLclEnv,
getEnvs, setEnvs,
xoptM, doptM, goptM, woptM,
setXOptM, unsetGOptM, unsetWOptM,
whenDOptM, whenGOptM, whenWOptM, whenXOptM,
getGhcMode,
withDoDynamicToo,
getEpsVar,
getEps,
updateEps, updateEps_,
getHpt, getEpsAndHpt,
-- * Arrow scopes
newArrowScope, escapeArrowScope,
-- * Unique supply
newUnique, newUniqueSupply, newLocalName, newName,
newSysName, newSysLocalId, newSysLocalIds,
-- * Accessing input/output
newTcRef, readTcRef, writeTcRef, updTcRef,
-- * Debugging
traceTc, traceRn, traceOptTcRn, traceTcRn,
getPrintUnqualified,
printForUserTcRn,
debugDumpTcRn,
traceIf, traceHiDiffs, traceOptIf,
debugTc,
-- * Typechecker global environment
setModule, getIsGHCi, getGHCiMonad, getInteractivePrintName,
tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv, getRecFieldEnv,
getDeclaredDefaultTys,
addDependentFiles,
-- * Error management
getSrcSpanM, setSrcSpan, addLocM,
wrapLocM, wrapLocFstM, wrapLocSndM,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
addErrAt, addErrs,
checkErr,
addMessages,
discardWarnings,
-- * Shared error message stuff: renamer and typechecker
mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
reportWarning, recoverM, mapAndRecoverM, mapAndReportM,
tryTc,
askNoErrs, discardErrs,
tryTcErrs, tryTcLIE, tryTcLIE_,
checkNoErrs, whenNoErrs,
ifErrsM, failIfErrsM,
checkTH, failTH,
-- * Context management for the type checker
getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
-- * Error message generation (type checker)
addErrTc, addErrsTc,
addErrTcM, mkErrTcM,
failWithTc, failWithTcM,
checkTc, checkTcM,
failIfTc, failIfTcM,
warnIf, warnTc, warnTcM,
addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
-- * Type constraints
newTcEvBinds,
addTcEvBind,
getTcEvBinds, getTcEvBindsMap,
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, emitInsoluble,
discardConstraints, captureConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
getLclTypeEnv, setLclTypeEnv,
traceTcConstraints, emitWildCardHoleConstraints,
-- * Template Haskell context
recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
-- * Safe Haskell context
recordUnsafeInfer, finalSafeMode, fixSafeInstances,
-- * Stuff for the renamer's local env
getLocalRdrEnv, setLocalRdrEnv,
-- * Stuff for interface decls
mkIfLclEnv,
initIfaceTcRn,
initIfaceCheck,
initIfaceTc,
initIfaceLcl,
getIfModule,
failIfM,
forkM_maybe,
forkM,
-- * Types etc.
module TcRnTypes,
module IOEnv
) where
#include "HsVersions.h"
......@@ -507,12 +622,6 @@ updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef ref fn = liftIO $ do { old <- readIORef ref
; writeIORef ref (fn old) }
updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
-- Returns previous value
updTcRefX ref fn = liftIO $ do { old <- readIORef ref
; writeIORef ref (fn old)
; return old }
{-
************************************************************************
* *
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment