Second attempt to fix sizeExpr
authorSimon Marlow <marlowsd@gmail.com>
Fri, 17 Jun 2016 10:21:52 +0000 (11:21 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 22 Jun 2016 09:00:10 +0000 (10:00 +0100)
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

compiler/coreSyn/CoreUnfold.hs
compiler/typecheck/TcRnMonad.hs

index 27045ff..885e965 100644 (file)
@@ -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;
index 1747ce0..5aed70c 100644 (file)
@@ -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 }
-
 {-
 ************************************************************************
 *                                                                      *