compiler/basicTypes/Name.hs

@@ -189,7 +189,6 @@ nameSrcSpan name = n_loc  name
 ************************************************************************
 -}
 
-nameIsLocalOrFrom :: Module -> Name -> Bool
 isInternalName    :: Name -> Bool
 isExternalName    :: Name -> Bool
 isSystemName      :: Name -> Bool
@@ -218,9 +217,32 @@ nameModule_maybe (Name { n_sort = External mod})    = Just mod
 nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
 nameModule_maybe _                                  = Nothing
 
+nameIsLocalOrFrom :: Module -> Name -> Bool
+-- ^ Returns True if the name is
+--   (a) Internal
+--   (b) External but from the specified module
+--   (c) External but from the 'interactive' package
+--
+-- The key idea is that
+--    False means: the entity is defined in some other module
+--                 you can find the details (type, fixity, instances)
+--                     in some interface file
+--                 those details will be stored in the EPT or HPT
+--
+--    True means:  the entity is defined in this module or earlier in
+--                     the GHCi session
+--                 you can find details (type, fixity, instances) in the
+--                     TcGblEnv or TcLclEnv
+--
+-- The isInteractiveModule part is because successive interactions of a GCHi session
+-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come
+-- from the magic 'interactive' package; and all the details are kept in the
+-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.
+-- See Note [The interactive package] in HscTypes
+
 nameIsLocalOrFrom from name
-  | isExternalName name = from == nameModule name
-  | otherwise           = True
+  | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod
+  | otherwise                         = True
 
 isTyVarName :: Name -> Bool
 isTyVarName name = isTvOcc (nameOccName name)
@@ -334,7 +356,8 @@ localiseName n = n { n_sort = Internal }
 -- |Create a localised variant of a name.
 --
 -- If the name is external, encode the original's module name to disambiguate.
---
+-- SPJ says: this looks like a rather odd-looking function; but it seems to
+--           be used only during vectorisation, so I'm not going to worry
 mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
 mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
   where

compiler/basicTypes/OccName.hs

@@ -3,7 +3,7 @@
 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 -}
 
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
 
 -- |
 -- #name_types#
@@ -793,6 +793,29 @@ type TidyOccEnv = UniqFM Int
 
 * When looking for a renaming for "foo2" we strip off the "2" and start
   with "foo".  Otherwise if we tidy twice we get silly names like foo23.
+
+  However, if it started with digits at the end, we always make a name
+  with digits at the end, rather than shortening "foo2" to just "foo",
+  even if "foo" is unused.  Reasons:
+     - Plain "foo" might be used later
+     - We use trailing digits to subtly indicate a unification variable
+       in typechecker error message; see TypeRep.tidyTyVarBndr
+
+We have to take care though! Consider a machine-generated module (Trac #10370)
+  module Foo where
+     a1 = e1
+     a2 = e2
+     ...
+     a2000 = e2000
+Then "a1", "a2" etc are all marked taken.  But now if we come across "a7" again,
+we have to do a linear search to find a free one, "a20001".  That might just be
+acceptable once.  But if we now come across "a8" again, we don't want to repeat
+that search.
+
+So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for
+starting the search; and we make sure to update the starting point for "a"
+after we allocate a new one.
+
 -}
 
 type TidyOccEnv = UniqFM Int    -- The in-scope OccNames
@@ -809,24 +832,30 @@ initTidyOccEnv = foldl add emptyUFM
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
-        Just n  -> find n
-        Nothing -> (addToUFM env fs 1, occ)
+      Nothing -> (addToUFM env fs 1, occ)   -- Desired OccName is free
+      Just {} -> case lookupUFM env base1 of
+                   Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
+                   Just n  -> find 1 n
   where
     base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
-    base = dropWhileEndLE isDigit (unpackFS fs)
+    base  = dropWhileEndLE isDigit (unpackFS fs)
+    base1 = mkFastString (base ++ "1")
 
-    find n
+    find !k !n
       = case lookupUFM env new_fs of
-          Just n' -> find (n1 `max` n')
-                     -- The max ensures that n increases, avoiding loops
-          Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1,
-                      OccName occ_sp new_fs)
-                     -- We update only the beginning and end of the
-                     -- chain that find explores; it's a little harder to
-                     -- update the middle and there's no real need.
+          Just {} -> find (k+1 :: Int) (n+k)
+                       -- By using n+k, the n arguemt to find goes
+                       --    1, add 1, add 2, add 3, etc which
+                       -- moves at quadratic speed through a dense patch
+
+          Nothing -> (new_env, OccName occ_sp new_fs)
        where
-         n1 = n+1
          new_fs = mkFastString (base ++ show n)
+         new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1)
+                     -- Update:  base_fs, so that next time we'll start whwere we left off
+                     --          new_fs,  so that we know it is taken
+                     -- If they are the same (n==1), the former wins
+                     -- See Note [TidyOccEnv]
 
 {-
 ************************************************************************

compiler/basicTypes/RdrName.hs

@@ -86,6 +86,22 @@ import Data.Data
 
 -- | Do not use the data constructors of RdrName directly: prefer the family
 -- of functions that creates them, such as 'mkRdrUnqual'
+--
+-- - Note: A Located RdrName will only have API Annotations if it is a
+--         compound one,
+--   e.g.
+--
+-- > `bar`
+-- > ( ~ )
+--
+-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
+--           'ApiAnnotation.AnnOpen'  @'('@ or @'['@ or @'[:'@,
+--           'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,,
+--           'ApiAnnotation.AnnBackquote' @'`'@,
+--           'ApiAnnotation.AnnVal','ApiAnnotation.AnnTildehsh',
+--           'ApiAnnotation.AnnTilde',
+
+-- For details on above see note [Api annotations] in ApiAnnotation
 data RdrName
   = Unqual OccName
         -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.

compiler/basicTypes/SrcLoc.hs

 -- (c) The University of Glasgow, 1992-2006
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveFoldable     #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
    -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
    -- When the earliest compiler we want to boostrap with is
@@ -43,7 +48,7 @@ module SrcLoc (
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        showUserSpan, pprUserRealSpan,
+        pprUserRealSpan,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -77,6 +82,10 @@ import Util
 import Outputable
 import FastString
 
+#if __GLASGOW_HASKELL__ < 709
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable )
+#endif
 import Data.Bits
 import Data.Data
 import Data.List
@@ -475,9 +484,6 @@ instance Outputable SrcSpan where
 --           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
 --           RealSrcSpan s -> ppr s
 
-showUserSpan :: Bool -> SrcSpan -> String
-showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span)
-
 pprUserSpan :: Bool -> SrcSpan -> SDoc
 pprUserSpan _         (UnhelpfulSpan s) = ftext s
 pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s
@@ -515,6 +521,8 @@ pprUserRealSpan show_path (SrcSpanPoint src_path line col)
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
 data GenLocated l e = L l e
   deriving (Eq, Ord, Typeable, Data)
+deriving instance Foldable    (GenLocated l)
+deriving instance Traversable (GenLocated l)
 
 type Located e = GenLocated SrcSpan e
 type RealLocated e = GenLocated RealSrcSpan e

compiler/cmm/CLabel.hs

@@ -897,7 +897,7 @@ labelDynamic dflags this_pkg this_mod lbl =
 
    PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
 
-   HpcTicksLabel m        -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
+   HpcTicksLabel m        -> not (gopt Opt_Static dflags) && this_mod /= m
 
    -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
    _                 -> False

compiler/cmm/CmmCommonBlockElim.hs

-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, BangPatterns #-}
 module CmmCommonBlockElim
   ( elimCommonBlocks
   )
@@ -9,6 +9,7 @@ import BlockId
 import Cmm
 import CmmUtils
 import CmmContFlowOpt
+-- import PprCmm ()
 import Prelude hiding (iterate, succ, unzip, zip)
 
 import Hoopl hiding (ChangeFlag)
@@ -19,9 +20,8 @@ import Data.Word
 import qualified Data.Map as M
 import Outputable
 import UniqFM
-
-my_trace :: String -> SDoc -> a -> a
-my_trace = if False then pprTrace else \_ _ a -> a
+import Unique
+import Control.Arrow (first, second)
 
 -- -----------------------------------------------------------------------------
 -- Eliminate common blocks
@@ -37,40 +37,72 @@ my_trace = if False then pprTrace else \_ _ a -> a
 -- is made redundant by the old block.
 -- Otherwise, it is added to the useful blocks.
 
+-- To avoid comparing every block with every other block repeatedly, we group
+-- them by
+--   * a hash of the block, ignoring labels (explained below)
+--   * the list of outgoing labels
+-- The hash is invariant under relabeling, so we only ever compare within
+-- the same group of blocks.
+--
+-- The list of outgoing labels is updated as we merge blocks (that is why they
+-- are not included in the hash, which we want to calculate only once).
+--
+-- All in all, two blocks should never be compared if they have different
+-- hashes, and at most once otherwise. Previously, we were slower, and people
+-- rightfully complained: #10397
+
 -- TODO: Use optimization fuel
 elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
-     env = iterate hashed_blocks mapEmpty
-     hashed_blocks = map (\b -> (hash_block b, b)) $ postorderDfs g
-
--- Iterate over the blocks until convergence
-iterate :: [(HashCode,CmmBlock)] -> BlockEnv BlockId -> BlockEnv BlockId
-iterate blocks subst =
-  case foldl common_block (False, emptyUFM, subst) blocks of
-    (changed,  _, subst)
-       | changed   -> iterate blocks subst
-       | otherwise -> subst
+     env = iterate mapEmpty blocks_with_key
+     groups = groupByInt hash_block (postorderDfs g)
+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
+
+-- Invariant: The blocks in the list are pairwise distinct
+-- (so avoid comparing them again)
+type DistinctBlocks = [CmmBlock]
+type Key = [Label]
+type Subst = BlockEnv BlockId
+
+-- The outer list groups by hash. We retain this grouping throughout.
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
+    | mapNull new_substs = subst
+    | otherwise = iterate subst' updated_blocks
+  where
+    grouped_blocks :: [[(Key, [DistinctBlocks])]]
+    grouped_blocks = map groupByLabel blocks
 
-type State  = (ChangeFlag, UniqFM [CmmBlock], BlockEnv BlockId)
+    merged_blocks :: [[(Key, DistinctBlocks)]]
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+      where
+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+          where
+            (new_subst2, db) = mergeBlockList subst dbs
 
-type ChangeFlag = Bool
-type HashCode = Int
+    subst' = subst `mapUnion` new_substs
+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
 
--- Try to find a block that is equal (or ``common'') to b.
-common_block :: State -> (HashCode, CmmBlock) -> State
-common_block (old_change, bmap, subst) (hash, b) =
-  case lookupUFM bmap hash of
-    Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
-                     mapLookup bid subst) of
-                 (Just b', Nothing)                         -> addSubst b'
-                 (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
-                                     | otherwise -> (old_change, bmap, subst)
-                 _ -> (old_change, addToUFM bmap hash (b : bs), subst)
-    Nothing -> (old_change, addToUFM bmap hash [b], subst)
-  where bid = entryLabel b
-        addSubst b' = my_trace "found new common block" (ppr bid <> char '=' <> ppr (entryLabel b')) $
-                      (True, bmap, mapInsert bid (entryLabel b') subst)
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
+  where
+    go [] = (mapEmpty, existing)
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
+  where
+    go !new_subst1 b [] = (new_subst1, b)
+    go !new_subst1 b1 (b2:bs) = go new_subst b bs
+      where
+        (new_subst2, b) =  mergeBlocks subst b1 b2
+        new_subst = new_subst1 `mapUnion` new_subst2
 
 
 -- -----------------------------------------------------------------------------
@@ -79,9 +111,16 @@ common_block (old_change, bmap, subst) (hash, b) =
 -- Below here is mostly boilerplate: hashing blocks ignoring labels,
 -- and comparing blocks modulo a label mapping.
 
--- To speed up comparisons, we hash each basic block modulo labels.
+-- To speed up comparisons, we hash each basic block modulo jump labels.
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
+
+-- We want to get as many small buckets as possible, as comparing blocks is
+-- expensive. So include as much as possible in the hash. Ideally everything
+-- that is compared with (==) in eqBlockBodyWith.
+
+type HashCode = Int
+
 hash_block :: CmmBlock -> HashCode
 hash_block block =
   fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
@@ -104,7 +143,7 @@ hash_block block =
         hash_node _ = error "hash_node: unknown Cmm node!"
 
         hash_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal _) = 117
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
         hash_reg   (CmmGlobal _)    = 19
 
         hash_e :: CmmExpr -> Word32
@@ -132,6 +171,9 @@ hash_block block =
 
         cvt = fromInteger . toInteger
 
+        hash_unique :: Uniquable a => a -> Word32
+        hash_unique = cvt . getKey . getUnique
+
 -- | Ignore these node types for equality
 dont_care :: CmmNode O x -> Bool
 dont_care CmmComment {}  = True
@@ -188,13 +230,18 @@ eqExprWith eqBid = eq
 -- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
 eqBlockBodyWith eqBid block block'
-  = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
-    eqLastWith eqBid l l'
+  {-
+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
+  -}
+  = equal
   where (_,m,l)   = blockSplit block
         nodes     = filter (not . dont_care) (blockToList m)
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
+        equal = and (zipWith (eqMiddleWith eqBid) nodes nodes') &&
+                eqLastWith eqBid l l'
 
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
@@ -237,3 +284,18 @@ copyTicks env g
               (CmmEntry lbl scp1, code) = blockSplitHead to
           in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
              foldr blockCons code (map CmmTick ticks)
+
+-- Group by [Label]
+groupByLabel :: [(Key, a)] -> [(Key, [a])]
+groupByLabel = go M.empty
+  where
+    go !m [] = M.elems m
+    go !m ((k,v) : entries) = go (M.alter adjust k' m) entries
+      where k' = map getUnique k
+            adjust Nothing       = Just (k,[v])
+            adjust (Just (_,vs)) = Just (k,v:vs)
+
+
+groupByInt :: (a -> Int) -> [a] -> [[a]]
+groupByInt f xs = eltsUFM $ List.foldl' go emptyUFM xs
+  where go m x = alterUFM (Just . maybe [x] (x:)) m (f x)

compiler/cmm/CmmExpr.hs

@@ -20,7 +20,6 @@ module CmmExpr
     , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
     , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
     , regSetToList
-    , regUsedIn
 
     , Area(..)
     , module CmmMachOp
@@ -372,17 +371,6 @@ instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
   foldRegsDefd _      _ set Nothing  = set
   foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
 
------------------------------------------------------------------------------
--- Another reg utility
-
-regUsedIn :: CmmReg -> CmmExpr -> Bool
-_   `regUsedIn` CmmLit _         = False
-reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
-reg `regUsedIn` CmmReg reg'      = reg == reg'
-reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
-reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
-_   `regUsedIn` CmmStackSlot _ _ = False
-
 -----------------------------------------------------------------------------
 --              Global STG registers
 -----------------------------------------------------------------------------
@@ -397,6 +385,31 @@ vgcFlag :: CmmType -> VGcPtr
 vgcFlag ty | isGcPtrType ty = VGcPtr
            | otherwise      = VNonGcPtr
 
+{-
+Note [Overlapping global registers]
+
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
 data GlobalReg
   -- Argument and return registers
   = VanillaReg                  -- pointers, unboxed ints and chars

compiler/cmm/CmmParse.y

@@ -575,6 +575,10 @@ importName
         : NAME  
         { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
 
+        -- as previous 'NAME', but 'IsData'
+        | 'CLOSURE' NAME
+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
+
         -- A label imported with an explicit packageId.
         | STRING NAME
         { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }

compiler/cmm/CmmSink.hs

@@ -510,11 +510,8 @@ okToInline _ _ _ = True
 
 -- -----------------------------------------------------------------------------
 
--- | @conflicts (r,e) stmt@ is @False@ if and only if the assignment
--- @r = e@ can be safely commuted past @stmt@.
---
--- We only sink "r = G" assignments right now, so conflicts is very simple:
---
+-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
+-- @r = e@ can be safely commuted past statement @node@.
 conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
 conflicts dflags (r, rhs, addr) node
 
@@ -548,13 +545,15 @@ conflicts dflags (r, rhs, addr) node
 -- Cmm expression
 globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
 globalRegistersConflict dflags expr node =
-    foldRegsDefd dflags (\b r -> b || (CmmGlobal r) `regUsedIn` expr) False node
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+                 False node
 
 -- Returns True if node defines any local registers that are used in the
 -- Cmm expression
 localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
 localRegistersConflict dflags expr node =
-    foldRegsDefd dflags (\b r -> b || (CmmLocal  r) `regUsedIn` expr) False node
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)
+                 False node
 
 -- Note [Sinking and calls]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -693,7 +692,7 @@ loadAddr dflags e w =
   case e of
    CmmReg r       -> regAddr dflags r 0 w
    CmmRegOff r i  -> regAddr dflags r i w
-   _other | CmmGlobal Sp `regUsedIn` e -> StackMem
+   _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem
           | otherwise -> AnyMem
 
 regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem

compiler/cmm/CmmUtils.hs

@@ -42,6 +42,9 @@ module CmmUtils(
         cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
         cmmConstrTag1,
 
+        -- Overlap and usage
+        regsOverlap, regUsedIn,
+
         -- Liveness and bitmaps
         mkLiveness,
 
@@ -75,6 +78,7 @@ import Unique
 import UniqSupply
 import DynFlags
 import Util
+import CodeGen.Platform
 
 import Data.Word
 import Data.Maybe
@@ -394,6 +398,38 @@ cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
 cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
 
 
+-----------------------------------------------------------------------------
+-- Overlap and usage
+
+-- | Returns True if the two STG registers overlap on the specified
+-- platform, in the sense that writing to one will clobber the
+-- other. This includes the case that the two registers are the same
+-- STG register. See Note [Overlapping global registers] for details.
+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,
+    Just real' <- globalRegMaybe (targetPlatform dflags) g',
+    real == real'
+    = True
+regsOverlap _ reg reg' = reg == reg'
+
+-- | Returns True if the STG register is used by the expression, in
+-- the sense that a store to the register might affect the value of
+-- the expression.
+--
+-- We must check for overlapping registers and not just equal
+-- registers here, otherwise CmmSink may incorrectly reorder
+-- assignments that conflict due to overlap. See Trac #10521 and Note
+-- [Overlapping global registers].
+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
+regUsedIn dflags = regUsedIn_ where
+  _   `regUsedIn_` CmmLit _         = False
+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e
+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es
+  _   `regUsedIn_` CmmStackSlot _ _ = False
+
 --------------------------------------------
 --
 --        mkLiveness

compiler/cmm/PprC.hs

@@ -1219,7 +1219,6 @@ commafy xs = hsep $ punctuate comma xs
 
 -- Print in C hex format: 0x13fa
 pprHexVal :: Integer -> Width -> SDoc
-pprHexVal 0 _ = ptext (sLit "0x0")
 pprHexVal w rep
   | w < 0     = parens (char '-' <>
                     ptext (sLit "0x") <> intToDoc (-w) <> repsuffix rep)
@@ -1239,7 +1238,9 @@ pprHexVal w rep
       repsuffix _ = char 'U'
 
       intToDoc :: Integer -> SDoc
-      intToDoc i = go (truncInt i)
+      intToDoc i = case truncInt i of
+                       0 -> char '0'
+                       v -> go v
 
       -- We need to truncate value as Cmm backend does not drop
       -- redundant bits to ease handling of negative values.

compiler/codeGen/StgCmmClosure.hs

@@ -754,8 +754,12 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
 -- was on. But it didn't work, and it wasn't strictly necessary
 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
 -- is unconditionally disabled. -- krc 1/2007
-
+--
+--
 -- Static closures are never themselves black-holed.
+--
+-- We also never black-hole non-updatable thunks.
+-- See Note [Black-holing non-updatable thunks]
 
 blackHoleOnEntry :: ClosureInfo -> Bool
 blackHoleOnEntry cl_info
@@ -766,9 +770,65 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
         LFReEntrant _ _ _ _          -> False
         LFLetNoEscape                   -> False
-        LFThunk _ _no_fvs _updatable _ _ -> True
+        LFThunk _ _no_fvs updatable _ _ -> updatable
         _other -> panic "blackHoleOnEntry"      -- Should never happen
 
+{-
+Note [Black-holing non-updatable thunks]
+=========================================
+
+We cannot black-hole non-updatable thunks otherwise we run into issues like
+Trac #10414. A single-entry (non-updatable) thunk can actually be entered more
+than once in a parallel program, if work is duplicated by two threads both
+entering the same updatable thunk before the other has blackholed it. So, we
+must not eagerly blackhole non-updatable thunks, or the second thread to enter
+one will become blocked indefinitely. (They are not blackholed by lazy
+blackholing either, since they have no associated update frame.)
+
+For instance, let's consider the following value (in pseudo-Core, example due to
+Reid Barton),
+
+    x = \u []  concat [[1], []]
+
+with the following definitions,
+
+    concat x = case x of
+        []       -> []
+        (:) x xs -> (++) x (concat xs)
+
+    (++) xs ys = case xs of
+        []         -> ys
+        (:) x rest -> (:) x ((++) rest ys)
+
+Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
+to WHNF and calls @(++)@ the heap will contain the following thunks,
+
+    x = 1 : y
+    y = \u []  (++) [] z
+    z = \s []  concat []
+
+Now that the stage is set, consider the follow evaluations by two racing threads
+A and B,
+
+  1. Both threads enter @y@ before either is able to replace it with an
+     indirection
+
+  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
+     replacing it with a black-hole
+
+  3. At some later point thread B does the same case analysis and also attempts
+     to enter @z@. However, it finds that it has been replaced with a black-hole
+     so it blocks.
+
+  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
+     accordingly. It does *not* update @z@, however, as it is single-entry. This
+     leaves Thread B blocked forever on a black-hole which will never be
+     updated.
+
+To avoid this sort of condition we never black-hole non-updatable thunks.
+-}
+
 isStaticClosure :: ClosureInfo -> Bool
 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 

compiler/codeGen/StgCmmExpr.hs

@@ -355,30 +355,59 @@ of Bool-returning primops was that tagToEnum# was added implicitly in the
 codegen and then optimized away. Now the call to tagToEnum# is explicit
 in the source code, which allows to optimize it away at the earlier stages
 of compilation (i.e. at the Core level).
+
+Note [Scrutinising VoidRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this STG code:
+   f = \[s : State# RealWorld] ->
+       case s of _ -> blah
+This is very odd.  Why are we scrutinising a state token?  But it
+can arise with bizarre NOINLINE pragmas (Trac #9964)
+    crash :: IO ()
+    crash = IO (\s -> let {-# NOINLINE s' #-}
+                          s' = s
+                      in (# s', () #))
+
+Now the trouble is that 's' has VoidRep, and we do not bind void
+arguments in the environment; they don't live anywhere.  See the
+calls to nonVoidIds in various places.  So we must not look up
+'s' in the environment.  Instead, just evaluate the RHS!  Simple.
+
+Note [Dodgy unsafeCoerce 1]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    case (x :: MutVar# Int) |> co of (y :: HValue)
+        DEFAULT -> ...
+We want to gnerate an assignment
+     y := x
+We want to allow this assignment to be generated in the case when the
+types are compatible, because this allows some slightly-dodgy but
+occasionally-useful casts to be used, such as in RtClosureInspect
+where we cast an HValue to a MutVar# so we can print out the contents
+of the MutVar#.  If instead we generate code that enters the HValue,
+then we'll get a runtime panic, because the HValue really is a
+MutVar#.  The types are compatible though, so we can just generate an
+assignment.
+
+Note [Dodgy unsafeCoerce 2]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [ticket #3132]: we might be looking at a case of a lifted Id that
+was cast to an unlifted type.  The Id will always be bottom, but we
+don't want the code generator to fall over here.  If we just emit an
+assignment here, the assignment will be type-incorrect Cmm.  Hence, we
+emit the usual enter/return code, (and because bottom must be
+untagged, it will be entered and the program will crash).  The Sequel
+is a type-correct assignment, albeit bogus.  The (dead) continuation
+loops; it would be better to invoke some kind of panic function here.
 -}
 
+cgCase (StgApp v []) _ (PrimAlt _) alts
+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]
+  , [(DEFAULT, _, _, rhs)] <- alts
+  = cgExpr rhs
 
-  -- Note [ticket #3132]: we might be looking at a case of a lifted Id
-  -- that was cast to an unlifted type.  The Id will always be bottom,
-  -- but we don't want the code generator to fall over here.  If we
-  -- just emit an assignment here, the assignment will be
-  -- type-incorrect Cmm.  Hence, we emit the usual enter/return code,
-  -- (and because bottom must be untagged, it will be entered and the
-  -- program will crash).
-  -- The Sequel is a type-correct assignment, albeit bogus.
-  -- The (dead) continuation loops; it would be better to invoke some kind
-  -- of panic function here.
-  --
-  -- However, we also want to allow an assignment to be generated
-  -- in the case when the types are compatible, because this allows
-  -- some slightly-dodgy but occasionally-useful casts to be used,
-  -- such as in RtClosureInspect where we cast an HValue to a MutVar#
-  -- so we can print out the contents of the MutVar#.  If we generate
-  -- code that enters the HValue, then we'll get a runtime panic, because
-  -- the HValue really is a MutVar#.  The types are compatible though,
-  -- so we can just generate an assignment.
 cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
-  | isUnLiftedType (idType v)
+  | isUnLiftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]
   || reps_compatible
   = -- assignment suffices for unlifted types
     do { dflags <- getDynFlags
@@ -392,7 +421,7 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
     reps_compatible = idPrimRep v == idPrimRep bndr
 
 cgCase scrut@(StgApp v []) _ (PrimAlt _) _
-  = -- fail at run-time, not compile-time
+  = -- See Note [Dodgy unsafeCoerce 2]
     do { dflags <- getDynFlags
        ; mb_cc <- maybeSaveCostCentre True
        ; _ <- withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
@@ -403,7 +432,9 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
        ; emit (mkBranch l)
        ; return AssignedDirectly
        }
-{-
+
+{- Note [Handle seq#]
+~~~~~~~~~~~~~~~~~~~~~
 case seq# a s of v
   (# s', a' #) -> e
 
@@ -417,7 +448,8 @@ is the same as the return convention for just 'a')
 -}
 
 cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
-  = -- handle seq#, same return convention as vanilla 'a'.
+  = -- Note [Handle seq#]
+    -- Use the same return convention as vanilla 'a'.
     cgCase (StgApp a []) bndr alt_type alts
 
 cgCase scrut bndr alt_type alts

compiler/codeGen/StgCmmPrim.hs

@@ -412,7 +412,9 @@ emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj
 -- Getting the size of pointer arrays
 
 emitPrimOp dflags [res] SizeofArrayOp [arg]
-   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg
+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))
+        (bWord dflags))
 emitPrimOp dflags [res] SizeofMutableArrayOp [arg]
    = emitPrimOp dflags [res] SizeofArrayOp [arg]
 emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
@@ -423,7 +425,8 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
 emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =
     emit $ mkAssign (CmmLocal res)
     (cmmLoadIndexW dflags arg
-     (fixedHdrSizeW dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) (bWord dflags))
+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
+        (bWord dflags))
 emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =
     emitPrimOp dflags [res] SizeofSmallArrayOp [arg]
 

compiler/codeGen/StgCmmUtils.hs

@@ -401,11 +401,13 @@ type Stmt = (LocalReg, CmmExpr) -- r := e
 
 emitMultiAssign []    []    = return ()
 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
-emitMultiAssign regs  rhss  = ASSERT( equalLength regs rhss )
-                              unscramble ([1..] `zip` (regs `zip` rhss))
+emitMultiAssign regs rhss   = do
+  dflags <- getDynFlags
+  ASSERT( equalLength regs rhss )
+    unscramble dflags ([1..] `zip` (regs `zip` rhss))
 
-unscramble :: [Vrtx] -> FCode ()
-unscramble vertices = mapM_ do_component components
+unscramble :: DynFlags -> [Vrtx] -> FCode ()
+unscramble dflags vertices = mapM_ do_component components
   where
         edges :: [ (Vrtx, Key, [Key]) ]
         edges = [ (vertex, key1, edges_from stmt1)
@@ -432,7 +434,7 @@ unscramble vertices = mapM_ do_component components
             u <- newUnique
             let (to_tmp, from_tmp) = split dflags u first_stmt
             mk_graph to_tmp
-            unscramble rest
+            unscramble dflags rest
             mk_graph from_tmp
 
         split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
@@ -445,8 +447,8 @@ unscramble vertices = mapM_ do_component components
         mk_graph :: Stmt -> FCode ()
         mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
 
-mustFollow :: Stmt -> Stmt -> Bool
-(reg, _) `mustFollow` (_, rhs) = CmmLocal reg `regUsedIn` rhs
+        mustFollow :: Stmt -> Stmt -> Bool
+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
 
 -------------------------------------------------------------------------
 --      mkSwitch

compiler/coreSyn/CoreLint.hs

@@ -9,14 +9,14 @@ A ``lint'' pass to check for Core correctness
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fprof-auto #-}
 
-module CoreLint ( 
-    lintCoreBindings, lintUnfolding, 
+module CoreLint (
+    lintCoreBindings, lintUnfolding,
     lintPassResult, lintInteractiveExpr, lintExpr,
     lintAnnots,
 
     -- ** Debug output
-    CoreLint.showPass, showPassIO, endPass, endPassIO, 
-    dumpPassResult, 
+    CoreLint.showPass, showPassIO, endPass, endPassIO,
+    dumpPassResult,
     CoreLint.dumpIfSet,
  ) where
 
@@ -31,6 +31,7 @@ import Literal
 import DataCon
 import TysWiredIn
 import TysPrim
+import TcType ( isFloatingTy )
 import Var
 import VarEnv
 import VarSet
@@ -615,6 +616,15 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
      ; alt_ty   <- lintInTy alt_ty
      ; var_ty   <- lintInTy (idType var)
 
+     -- See Note [Rules for floating-point comparisons] in PrelRules
+     ; let isLitPat (LitAlt _, _ , _) = True
+           isLitPat _                 = False
+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+                        "expression with literal pattern in case " ++
+                        "analysis (see Trac #9238).")
+          $$ text "scrut" <+> ppr scrut)
+
      ; case tyConAppTyCon_maybe (idType var) of
          Just tycon
               | debugIsOn &&
@@ -666,6 +676,26 @@ kind coercions and produce the following substitution which is to be
 applied in the type variables:
   k_ag   ~~>   * -> *
 
+Note [No alternatives lint check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case expressions with no alternatives are odd beasts, and worth looking at
+in the linter (cf Trac #10180).  We check two things:
+
+* exprIsHNF is false: certainly, it would be terribly wrong if the
+  scrutinee was already in head normal form.
+
+* exprIsBottom is true: we should be able to see why GHC believes the
+  scrutinee is diverging for sure.
+
+In principle, the first check is redundant: exprIsBottom == True will
+always imply exprIsHNF == False.  But the first check is reliable: If
+exprIsHNF == True, then there definitely is a problem (exprIsHNF errs
+on the right side).  If the second check triggers then it may be the
+case that the compiler got smarter elsewhere, and the empty case is
+correct, but that exprIsBottom is unable to see it. In particular, the
+empty-type check in exprIsBottom is an approximation. Therefore, this
+check is not fully reliable, and we keep both around.
+
 ************************************************************************
 *                                                                      *
 \subsection[lintCoreArgs]{lintCoreArgs}
@@ -1150,6 +1180,8 @@ lintCoercion the_co@(NthCo n co)
        ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
            (Just (tc_s, tys_s), Just (tc_t, tys_t))
              | tc_s == tc_t
+             , isDistinctTyCon tc_s || r /= Representational
+                 -- see Note [NthCo and newtypes] in Coercion
              , tys_s `equalLength` tys_t
              , n < length tys_s
              -> return (ks, ts, tt, tr)
@@ -1284,7 +1316,7 @@ lintCoercion this@(AxiomRuleCo co ts cs)
 
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-data LintEnv 
+data LintEnv
   = LE { le_flags :: LintFlags       -- Linting the result of this pass
        , le_loc   :: [LintLocInfo]   -- Locations
        , le_subst :: TvSubst         -- Current type substitution; we also use this
@@ -1398,7 +1430,7 @@ addMsg env msgs msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m
-  = LintM $ \ env errs -> 
+  = LintM $ \ env errs ->
     unLintM m (env { le_loc = extra_loc : le_loc env }) errs
 
 inCasePat :: LintM Bool         -- A slight hack; see the unique call site
@@ -1409,18 +1441,18 @@ inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
 
 addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars vars m
-  = LintM $ \ env errs -> 
-    unLintM m (env { le_subst = extendTvInScopeList (le_subst env) vars }) 
+  = LintM $ \ env errs ->
+    unLintM m (env { le_subst = extendTvInScopeList (le_subst env) vars })
               errs
 
 addInScopeVar :: Var -> LintM a -> LintM a
 addInScopeVar var m
-  = LintM $ \ env errs -> 
+  = LintM $ \ env errs ->
     unLintM m (env { le_subst = extendTvInScope (le_subst env) var }) errs
 
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendSubstL tv ty m
-  = LintM $ \ env errs -> 
+  = LintM $ \ env errs ->
     unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
 
 updateTvSubst :: TvSubst -> LintM a -> LintM a
@@ -1759,7 +1791,7 @@ withoutAnnots pass guts = do
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
   -- them in absence of @Opt_Debug@?
-  let nukeTicks = snd . stripTicks (not . tickishIsCode)
+  let nukeTicks = stripTicksE (not . tickishIsCode)
       nukeAnnotsBind :: CoreBind -> CoreBind
       nukeAnnotsBind bind = case bind of
         Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs

compiler/coreSyn/CoreSubst.hs

@@ -20,7 +20,7 @@ module CoreSubst (
         substTickish, substVarSet,
 
         -- ** Operations on substitutions
-        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
+        emptySubst, mkEmptySubst, mkGblSubst, mkOpenSubst, substInScope, isEmptySubst,
         extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
         extendCvSubst, extendCvSubstList,
         extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
@@ -178,24 +178,106 @@ TvSubstEnv and CvSubstEnv?
 
 * For TyVars, only coercion variables can possibly change, and they are
   easy to spot
+
+Note [IdSubstEnv]
+~~~~~~~~~~~~~~~~~
+An IdSubstEnv has a "local environment" of type (IdEnv CoreExpr);
+this is extended when we meet a binder, in the usual way.  But it also
+has a "global environment" of type GblIdSubst.  This global envt is
+never modified during substitution.  Rather:
+
+ * The GblIdSubst is used when initialising the substitution via
+   mkGblSubst, to give an "ambient substitution" for the enclosing
+   context.
+
+ * On lookup, we look first in the local envt and then in the global envt
+   (see lookupIdSubst)
+
+ * The GblIdSubst is just a function; but since we need to delete things
+   from the substitution when passing a binder, we have to record a set
+   of Ids gis_del that must *not* be looked up in the gbl envt.
+
+All this is needed to support SimplEnv.substExpr, which starts off
+with a SimplIdSubst, which provides the ambient subsitution.
 -}
 
 -- | An environment for substituting for 'Id's
-type IdSubstEnv = IdEnv CoreExpr
+-- See Note [IdSubstEnv]
+data IdSubstEnv = ISE { ise_env  :: !(IdEnv CoreExpr)
+                      , ise_gbl  :: !GblIdSubst }
+
+data GblIdSubst = NoGIS
+                | GIS { gis_env :: !(InScopeSet -> Id -> Maybe CoreExpr)
+                      , gis_del :: !IdSet }  -- Deletions from gis_env
+
+instance Outputable IdSubstEnv where
+  ppr (ISE { ise_env = lcl, ise_gbl = gbl })
+    = ppr gbl $$ ppr lcl
+
+instance Outputable GblIdSubst where
+  ppr NoGIS = empty
+  ppr (GIS { gis_del = dels }) = ptext (sLit "GIS") <+> ppr dels
+
+lookupGIS :: GblIdSubst -> InScopeSet -> Id -> Maybe CoreExpr
+lookupGIS NoGIS _ _ = Nothing
+lookupGIS (GIS { gis_env = gbl_fn, gis_del = dels }) in_scope v
+  | v `elemVarSet` dels = Nothing
+  | otherwise           = gbl_fn in_scope v
+
+isEmptyIdSubst :: IdSubstEnv -> Bool
+isEmptyIdSubst (ISE { ise_env = lcl, ise_gbl = NoGIS }) = isEmptyVarEnv lcl
+isEmptyIdSubst _ = False
+
+emptyIdSubst :: IdSubstEnv
+emptyIdSubst = ISE { ise_env = emptyVarEnv, ise_gbl = NoGIS }
+
+extendIdSubstEnv :: IdSubstEnv -> Id -> CoreExpr -> IdSubstEnv
+extendIdSubstEnv ise v e = ise { ise_env = extendVarEnv (ise_env ise) v e }
+
+extendIdSubstEnvList :: IdSubstEnv -> [(Id,CoreExpr)] -> IdSubstEnv
+extendIdSubstEnvList ise prs = ise { ise_env = extendVarEnvList (ise_env ise) prs }
+
+delIdSubst :: IdSubstEnv -> Id -> IdSubstEnv
+delIdSubst (ISE { ise_env = lcl, ise_gbl = gbl }) v
+  = ISE { ise_env = delVarEnv lcl v, ise_gbl = delGIS gbl v }
+
+delIdSubstList :: IdSubstEnv -> [Id] -> IdSubstEnv
+delIdSubstList (ISE { ise_env = lcl, ise_gbl = gbl }) vs
+  = ISE { ise_env = delVarEnvList lcl vs, ise_gbl = delGISList gbl vs }
+
+delGIS :: GblIdSubst -> Id -> GblIdSubst
+delGIS NoGIS _ = NoGIS
+delGIS (GIS { gis_env = gbl, gis_del = dels }) v
+  = GIS { gis_env = gbl, gis_del = if isJust (gbl emptyInScopeSet v)
+                                   then extendVarSet dels v
+                                   else dels }
+
+delGISList :: GblIdSubst -> [Id] -> GblIdSubst
+delGISList NoGIS _ = NoGIS
+delGISList (GIS { gis_env = gbl, gis_del = dels }) vs
+  = GIS { gis_env = gbl, gis_del = extendVarSetList dels del_vs }
+  where
+    del_vs = [ v | v <- vs, isJust (gbl emptyInScopeSet v)]
 
 ----------------------------
 isEmptySubst :: Subst -> Bool
 isEmptySubst (Subst _ id_env tv_env cv_env)
-  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
+  = isEmptyIdSubst id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
 
 emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
+emptySubst = Subst emptyInScopeSet emptyIdSubst emptyVarEnv emptyVarEnv
 
 mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
+mkEmptySubst in_scope = Subst in_scope emptyIdSubst emptyVarEnv emptyVarEnv
 
-mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
+mkGblSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv
+           -> (InScopeSet -> Id -> Maybe CoreExpr)
+           -> Subst
+mkGblSubst in_scope tvs cvs lookup_id
+ = Subst in_scope id_subst tvs cvs
+ where
+    id_subst = ISE { ise_env = emptyVarEnv
+                   , ise_gbl = GIS { gis_env = lookup_id, gis_del = emptyVarSet } }
 
 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
 substInScope :: Subst -> InScopeSet
@@ -204,17 +286,17 @@ substInScope (Subst in_scope _ _ _) = in_scope
 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
 -- while preserving the in-scope set
 zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyIdSubst emptyVarEnv emptyVarEnv
 
 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
+extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendIdSubstEnv ids v r) tvs cvs
 
 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
+extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendIdSubstEnvList ids prs) tvs cvs
 
 -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
@@ -260,9 +342,10 @@ extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var r
 
 -- | Find the substitution for an 'Id' in the 'Subst'
 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _ _) v
+lookupIdSubst doc (Subst in_scope (ISE { ise_env = lcl, ise_gbl = gbl }) _ _) v
   | not (isLocalId v) = Var v
-  | Just e  <- lookupVarEnv ids       v = e
+  | Just e <- lookupVarEnv lcl        v = e
+  | Just e <- lookupGIS gbl in_scope  v = e
   | Just v' <- lookupInScope in_scope v = Var v'
         -- Vital! See Note [Extending the Subst]
   | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v
@@ -278,14 +361,15 @@ lookupCvSubst :: Subst -> CoVar -> Coercion
 lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
 
 delBndr :: Subst -> Var -> Subst
+-- Doesn't work for gbl_ids
 delBndr (Subst in_scope ids tvs cvs) v
   | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
   | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
-  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
+  | otherwise = Subst in_scope (delIdSubst ids v) tvs cvs
 
 delBndrs :: Subst -> [Var] -> Subst
 delBndrs (Subst in_scope ids tvs cvs) vs
-  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
+  = Subst in_scope (delIdSubstList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
       -- Easiest thing is just delete all from all!
 
 -- | Simultaneously substitute for a bunch of variables
@@ -293,10 +377,11 @@ delBndrs (Subst in_scope ids tvs cvs) vs
 --   ie the substitution for   (\x \y. e) a1 a2
 --      so neither x nor y scope over a1 a2
 mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
-mkOpenSubst in_scope pairs = Subst in_scope
-                                   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
-                                   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
-                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
+mkOpenSubst in_scope pairs
+  = Subst in_scope
+          (ISE { ise_env = mkVarEnv [(id,e)  | (id, e) <- pairs, isId id], ise_gbl = NoGIS})
+          (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+          (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
 
 ------------------------------
 isInScope :: Var -> Subst -> Bool
@@ -313,20 +398,20 @@ addInScopeSet (Subst in_scope ids tvs cvs) vs
 extendInScope :: Subst -> Var -> Subst
 extendInScope (Subst in_scope ids tvs cvs) v
   = Subst (in_scope `extendInScopeSet` v)
-          (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
+          (ids `delIdSubst` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
 
 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
 extendInScopeList :: Subst -> [Var] -> Subst
 extendInScopeList (Subst in_scope ids tvs cvs) vs
   = Subst (in_scope `extendInScopeSetList` vs)
-          (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
+          (ids `delIdSubstList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
 
 -- | Optimized version of 'extendInScopeList' that can be used if you are certain
 -- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
 extendInScopeIds :: Subst -> [Id] -> Subst
 extendInScopeIds (Subst in_scope ids tvs cvs) vs
   = Subst (in_scope `extendInScopeSetList` vs)
-          (ids `delVarEnvList` vs) tvs cvs
+          (ids `delIdSubstList` vs) tvs cvs
 
 setInScope :: Subst -> InScopeSet -> Subst
 setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
@@ -497,8 +582,8 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
 
         -- Extend the substitution if the unique has changed
         -- See the notes with substTyVarBndr for the delVarEnv
-    new_env | no_change = delVarEnv env old_id
-            | otherwise = extendVarEnv env old_id (Var new_id)
+    new_env | no_change = delIdSubst env old_id
+            | otherwise = extendIdSubstEnv env old_id (Var new_id)
 
     no_change = id1 == old_id
         -- See Note [Extending the Subst]
@@ -553,7 +638,7 @@ clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
     id2     = substIdType subst id1
     new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
     (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
-                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)
+                        | otherwise      = (extendIdSubstEnv idvs old_id (Var new_id), cvs)
 
 {-
 ************************************************************************
@@ -695,15 +780,16 @@ substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
                                        , ru_fn = fn_name, ru_rhs = rhs
                                        , ru_local = is_local })
-  = rule { ru_bndrs = bndrs',
-           ru_fn    = if is_local
+  = rule { ru_bndrs = bndrs'
+         , ru_fn    = if is_local
                         then subst_ru_fn fn_name
-                        else fn_name,
-           ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
-           ru_rhs   = simpleOptExprWith subst' rhs }
-           -- Do simple optimisation on RHS, in case substitution lets
-           -- you improve it.  The real simplifier never gets to look at it.
+                        else fn_name
+         , ru_args  = map (substExpr doc subst') args
+         , ru_rhs   = substExpr (text "foo") subst' rhs }
+           -- Do NOT optimise the RHS (previously we did simplOptExpr here)
+           -- See Note [Substitute lazily]
   where
+    doc = ptext (sLit "subst-rule") <+> ppr fn_name
     (subst', bndrs') = substBndrs subst bndrs
 
 ------------------
@@ -733,8 +819,22 @@ substTickish subst (Breakpoint n ids) = Breakpoint n (map do_one ids)
  where do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst
 substTickish _subst other = other
 
-{- Note [substTickish]
+{- Note [Substitute lazily]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The functions that substitute over IdInfo must be pretty lazy, becuause
+they are knot-tied by substRecBndrs.
 
+One case in point was Trac #10627 in which a rule for a function 'f'
+referred to 'f' (at a differnet type) on the RHS.  But instead of just
+substituting in the rhs of the rule, we were calling simpleOptExpr, which
+looked at the idInfo for 'f'; result <<loop>>.
+
+In any case we don't need to optimise the RHS of rules, or unfoldings,
+because the simplifier will do that.
+
+
+Note [substTickish]
+~~~~~~~~~~~~~~~~~~~~~~
 A Breakpoint contains a list of Ids.  What happens if we ever want to
 substitute an expression for one of these Ids?
 
@@ -954,6 +1054,7 @@ simple_app subst (Lam b e) (a:as)
     b2 = add_info subst' b b'
 simple_app subst (Var v) as
   | isCompulsoryUnfolding (idUnfolding v)
+  , isAlwaysActive (idInlineActivation v)
   -- See Note [Unfold compulsory unfoldings in LHSs]
   =  simple_app subst (unfoldingTemplate (idUnfolding v)) as
 simple_app subst (Tick t e) as
@@ -1065,9 +1166,9 @@ subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
         -- or there's some useful occurrence information
         -- See the notes with substTyVarBndr for the delSubstEnv
     new_id_subst | new_id /= old_id
-                 = extendVarEnv id_subst old_id (Var new_id)
+                 = extendIdSubstEnv id_subst old_id (Var new_id)
                  | otherwise
-                 = delVarEnv id_subst old_id
+                 = delIdSubst id_subst old_id
 
 ----------------------
 subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
@@ -1108,10 +1209,16 @@ to remain visible until Phase 1
 
 Note [Unfold compulsory unfoldings in LHSs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the user writes `map coerce = coerce` as a rule, the rule will only ever
-match if we replace coerce by its unfolding on the LHS, because that is the
-core that the rule matching engine will find. So do that for everything that
-has a compulsory unfolding. Also see Note [Desugaring coerce as cast] in Desugar
+When the user writes `RULES map coerce = coerce` as a rule, the rule
+will only ever match if simpleOptExpr replaces coerce by its unfolding
+on the LHS, because that is the core that the rule matching engine
+will find. So do that for everything that has a compulsory
+unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
+
+However, we don't want to inline 'seq', which happens to also have a
+compulsory unfolding, so we only do this unfolding only for things
+that are always-active.  See Note [User-defined RULES for seq] in MkId.
+
 
 ************************************************************************
 *                                                                      *

compiler/coreSyn/CoreSyn.hs

@@ -230,6 +230,10 @@ These data types are the heart of the compiler
 --       The inner case does not need a @Red@ alternative, because @x@
 --       can't be @Red@ at that program point.
 --
+--    5. Floating-point values must not be scrutinised against literals.
+--       See Trac #9238 and Note [Rules for floating-point comparisons]
+--       in PrelRules for rationale.
+--
 -- *  Cast an expression to a particular type.
 --    This is used to implement @newtype@s (a @newtype@ constructor or
 --    destructor just becomes a 'Cast' in Core) and GADTs.
@@ -326,6 +330,9 @@ simplifier calling findAlt with argument (LitAlt 3).  No no.  Integer
 literals are an opaque encoding of an algebraic data type, not of
 an unlifted literal, like all the others.
 
+Also, we do not permit case analysis with literal patterns on floating-point
+types. See Trac #9238 and Note [Rules for floating-point comparisons] in
+PrelRules for the rationale for this restriction.
 
 -------------------------- CoreSyn INVARIANTS ---------------------------
 

compiler/coreSyn/CoreUnfold.hs

@@ -27,7 +27,7 @@ module CoreUnfold (
         mkCompulsoryUnfolding, mkDFunUnfolding,
         specUnfolding,
 
-        interestingArg, ArgSummary(..),
+        ArgSummary(..),
 
         couldBeSmallEnoughToInline, inlineBoringOk,
         certainlyWillInline, smallEnoughToInline,
@@ -986,11 +986,20 @@ callSiteInline :: DynFlags
                -> CallCtxt              -- True <=> continuation is interesting
                -> Maybe CoreExpr        -- Unfolding, if any
 
+data ArgSummary = TrivArg       -- Nothing interesting
+                | NonTrivArg    -- Arg has structure
+                | ValueArg      -- Arg is a con-app or PAP
+                                -- ..or con-like. Note [Conlike is interesting]
+
 instance Outputable ArgSummary where
   ppr TrivArg    = ptext (sLit "TrivArg")
   ppr NonTrivArg = ptext (sLit "NonTrivArg")
   ppr ValueArg   = ptext (sLit "ValueArg")
 
+nonTriv ::  ArgSummary -> Bool
+nonTriv TrivArg = False
+nonTriv _       = True
+
 data CallCtxt
   = BoringCtxt
   | RhsCtxt             -- Rhs of a let-binding; see Note [RHS of lets]
@@ -1358,80 +1367,3 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info
                 -- But we want to aovid inlining large functions that return
                 -- constructors into contexts that are simply "interesting"
 
-{-
-************************************************************************
-*                                                                      *
-        Interesting arguments
-*                                                                      *
-************************************************************************
-
-Note [Interesting arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An argument is interesting if it deserves a discount for unfoldings
-with a discount in that argument position.  The idea is to avoid
-unfolding a function that is applied only to variables that have no
-unfolding (i.e. they are probably lambda bound): f x y z There is
-little point in inlining f here.
-
-Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But
-we must look through lets, eg (let x = e in C a b), because the let will
-float, exposing the value, if we inline.  That makes it different to
-exprIsHNF.
-
-Before 2009 we said it was interesting if the argument had *any* structure
-at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.
-
-But we don't regard (f x y) as interesting, unless f is unsaturated.
-If it's saturated and f hasn't inlined, then it's probably not going
-to now!
-
-Note [Conlike is interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-        f d = ...((*) d x y)...
-        ... f (df d')...
-where df is con-like. Then we'd really like to inline 'f' so that the
-rule for (*) (df d) can fire.  To do this
-  a) we give a discount for being an argument of a class-op (eg (*) d)
-  b) we say that a con-like argument (eg (df d)) is interesting
--}
-
-data ArgSummary = TrivArg       -- Nothing interesting
-                | NonTrivArg    -- Arg has structure
-                | ValueArg      -- Arg is a con-app or PAP
-                                -- ..or con-like. Note [Conlike is interesting]
-
-interestingArg :: CoreExpr -> ArgSummary
--- See Note [Interesting arguments]
-interestingArg e = go e 0
-  where
-    -- n is # value args to which the expression is applied
-    go (Lit {}) _          = ValueArg
-    go (Var v)  n
-       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
-                                        --    data constructors here
-       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
-       | n > 0             = NonTrivArg -- Saturated or unknown call
-       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
-                                        -- See Note [Conlike is interesting]
-       | otherwise         = TrivArg    -- n==0, no useful unfolding
-       where
-         conlike_unfolding = isConLikeUnfolding (idUnfolding v)
-
-    go (Type _)          _ = TrivArg
-    go (Coercion _)      _ = TrivArg
-    go (App fn (Type _)) n = go fn n
-    go (App fn (Coercion _)) n = go fn n
-    go (App fn _)        n = go fn (n+1)
-    go (Tick _ a)      n = go a n
-    go (Cast e _)        n = go e n
-    go (Lam v e)         n
-       | isTyVar v         = go e n
-       | n>0               = go e (n-1)
-       | otherwise         = ValueArg
-    go (Let _ e)         n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
-    go (Case {})         _ = NonTrivArg
-
-nonTriv ::  ArgSummary -> Bool
-nonTriv TrivArg = False
-nonTriv _       = True

compiler/coreSyn/CoreUtils.hs

@@ -44,7 +44,8 @@ module CoreUtils (
         dataConRepInstPat, dataConRepFSInstPat,
 
         -- * Working with ticks
-        stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
+        stripTicksTop, stripTicksTopE, stripTicksTopT,
+        stripTicksE, stripTicksT
     ) where
 
 #include "HsVersions.h"
@@ -77,10 +78,6 @@ import Pair
 import Data.Function       ( on )
 import Data.List
 import Data.Ord            ( comparing )
-import Control.Applicative
-#if __GLASGOW_HASKELL__ < 709
-import Data.Traversable    ( traverse )
-#endif
 import OrdList
 
 {-
@@ -300,10 +297,18 @@ mkTick t orig_expr = mkTick' id id orig_expr
          else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
 
     Var x
-      | not (isFunTy (idType x)) && tickishPlace t == PlaceCostCentre
+      | notFunction && tickishPlace t == PlaceCostCentre
       -> orig_expr
-      | canSplit
+      | notFunction && canSplit
       -> top $ Tick (mkNoScope t) $ rest expr
+      where
+        -- SCCs can be eliminated on variables provided the variable
+        -- is not a function.  In these cases the SCC makes no difference:
+        -- the cost of evaluating the variable will be attributed to its
+        -- definition site.  When the variable refers to a function, however,
+        -- an SCC annotation on the variable affects the cost-centre stack
+        -- when the function is called, so we must retain those.
+        notFunction = not (isFunTy (idType x))
 
     Lit{}
       | tickishPlace t == PlaceCostCentre
@@ -358,25 +363,37 @@ stripTicksTopT p = go []
 
 -- | Completely strip ticks satisfying a predicate from an
 -- expression. Note this is O(n) in the size of the expression!
-stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
-stripTicks p expr = (fromOL ticks, expr')
-  where (ticks, expr') = go expr
-        -- Note that  OrdList (Tickish Id) is a Monoid, which makes
-        -- ((,) (OrdList (Tickish Id))) an Applicative.
-        go (App e a)        = App <$> go e <*> go a
-        go (Lam b e)        = Lam b <$> go e
-        go (Let b e)        = Let <$> go_bs b <*> go e
-        go (Case e b t as)  = Case <$> go e <*> pure b <*> pure t
-                                   <*> traverse go_a as
-        go (Cast e c)       = Cast <$> go e <*> pure c
+stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
+stripTicksE p expr = go expr
+  where go (App e a)        = App (go e) (go a)
+        go (Lam b e)        = Lam b (go e)
+        go (Let b e)        = Let (go_bs b) (go e)
+        go (Case e b t as)  = Case (go e) b t (map go_a as)
+        go (Cast e c)       = Cast (go e) c
+        go (Tick t e)
+          | p t             = go e
+          | otherwise       = Tick t (go e)
+        go other            = other
+        go_bs (NonRec b e)  = NonRec b (go e)
+        go_bs (Rec bs)      = Rec (map go_b bs)
+        go_b (b, e)         = (b, go e)
+        go_a (c,bs,e)       = (c,bs, go e)
+
+stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
+stripTicksT p expr = fromOL $ go expr
+  where go (App e a)        = go e `appOL` go a
+        go (Lam _ e)        = go e
+        go (Let b e)        = go_bs b `appOL` go e
+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)
+        go (Cast e _)       = go e
         go (Tick t e)
-          | p t             = let (ts, e') = go e in (t `consOL` ts, e')
-          | otherwise       = Tick t <$> go e
-        go other            = pure other
-        go_bs (NonRec b e)  = NonRec b <$> go e
-        go_bs (Rec bs)      = Rec <$> traverse go_b bs
-        go_b (b, e)         = (,) <$> pure b <*> go e
-        go_a (c,bs,e)       = (,,) <$> pure c <*> pure bs <*> go e
+          | p t             = t `consOL` go e
+          | otherwise       = go e
+        go _                = nilOL
+        go_bs (NonRec _ e)  = go e
+        go_bs (Rec bs)      = concatOL (map go_b bs)
+        go_b (_, e)         = go e
+        go_a (_, _, e)      = go e
 
 {-
 ************************************************************************
@@ -663,6 +680,7 @@ getIdFromTrivialExpr :: CoreExpr -> Id
 getIdFromTrivialExpr e = go e
   where go (Var v) = v
         go (App f t) | not (isRuntimeArg t) = go f
+        go (Tick t e) | not (tickishIsCode t) = go e
         go (Cast e _) = go e
         go (Lam b e) | not (isRuntimeVar b) = go e
         go e = pprPanic "getIdFromTrivialExpr" (ppr e)