Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC

Commits:

11 changed files:

Changes:

  • compiler/GHC/Core.hs
    ... ... @@ -42,7 +42,8 @@ module GHC.Core (
    42 42
             foldBindersOfBindStrict, foldBindersOfBindsStrict,
    
    43 43
             collectBinders, collectTyBinders, collectTyAndValBinders,
    
    44 44
             collectNBinders, collectNValBinders_maybe,
    
    45
    -        collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds,
    
    45
    +        collectArgs, collectValArgs, stripNArgs, collectArgsTicks,
    
    46
    +        flattenBinds, glomValBinds, mapBindBndrs,
    
    46 47
             collectFunSimple,
    
    47 48
     
    
    48 49
             exprToType,
    
    ... ... @@ -2174,7 +2175,6 @@ foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds
    2174 2175
       where
    
    2175 2176
         fold_bind = (foldBindersOfBindStrict f)
    
    2176 2177
     
    
    2177
    -
    
    2178 2178
     rhssOfBind :: Bind b -> [Expr b]
    
    2179 2179
     rhssOfBind (NonRec _ rhs) = [rhs]
    
    2180 2180
     rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
    
    ... ... @@ -2189,6 +2189,21 @@ flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
    2189 2189
     flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
    
    2190 2190
     flattenBinds []                   = []
    
    2191 2191
     
    
    2192
    +glomValBinds :: [Bind b] -> [Bind b]
    
    2193
    +-- Glom all the value bindings into a single Rec;
    
    2194
    +-- Leave any type bindings as NonRecs, bringing them to the front
    
    2195
    +glomValBinds bs = go [] bs
    
    2196
    +  where
    
    2197
    +    go prs (b@(NonRec _ (Type {})) : bs) = b : go prs bs
    
    2198
    +    go prs (NonRec b r : bs) = go ((b,r) : prs) bs
    
    2199
    +    go prs (Rec rprs   : bs) = go (rprs ++ prs) bs
    
    2200
    +    go []  [] = []
    
    2201
    +    go prs [] = [Rec prs]
    
    2202
    +
    
    2203
    +mapBindBndrs :: (b -> b) -> Bind b -> Bind b
    
    2204
    +mapBindBndrs f (NonRec b r) = NonRec (f b) r
    
    2205
    +mapBindBndrs f (Rec prs)    = Rec (mapFst f prs)
    
    2206
    +
    
    2192 2207
     -- | We often want to strip off leading lambdas before getting down to
    
    2193 2208
     -- business. Variants are 'collectTyBinders', 'collectValBinders',
    
    2194 2209
     -- and 'collectTyAndValBinders'
    

  • compiler/GHC/Core/Opt/OccurAnal.hs
    ... ... @@ -39,7 +39,6 @@ import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr )
    39 39
     import GHC.Core.Coercion
    
    40 40
     import GHC.Core.Predicate   ( isDictId )
    
    41 41
     import GHC.Core.Type
    
    42
    -import GHC.Core.TyCo.Rep
    
    43 42
     import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )
    
    44 43
     
    
    45 44
     import GHC.Data.Maybe( orElse )
    
    ... ... @@ -50,6 +49,7 @@ import GHC.Types.Unique
    50 49
     import GHC.Types.Unique.FM
    
    51 50
     import GHC.Types.Unique.Set
    
    52 51
     import GHC.Types.Id
    
    52
    +import GHC.Types.Name( isExternalName )
    
    53 53
     import GHC.Types.Id.Info
    
    54 54
     import GHC.Types.Basic
    
    55 55
     import GHC.Types.Tickish
    
    ... ... @@ -65,6 +65,8 @@ import GHC.Utils.Misc
    65 65
     import GHC.Builtin.Names( runRWKey )
    
    66 66
     import GHC.Unit.Module( Module )
    
    67 67
     
    
    68
    +import qualified Data.Semigroup  as S( Semigroup(..) )
    
    69
    +import qualified Data.Monoid as S( Monoid(..) )
    
    68 70
     import Data.List (mapAccumL)
    
    69 71
     import Data.List.NonEmpty (NonEmpty (..))
    
    70 72
     
    
    ... ... @@ -100,18 +102,15 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
    100 102
         init_env = initOccEnv { occ_rule_act = active_rule
    
    101 103
                               , occ_unf_act  = active_unf }
    
    102 104
     
    
    103
    -    WUD final_usage occ_anald_binds = go binds init_env
    
    104
    -    WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel
    
    105
    -                                                    imp_rule_edges
    
    106
    -                                                    (flattenBinds binds)
    
    107
    -                                                    initial_uds
    
    105
    +    WUD final_usage occ_anald_binds = go binds                init_env
    
    106
    +    WUD _   occ_anald_glommed_binds = go (glomValBinds binds) init_env
    
    108 107
               -- It's crucial to re-analyse the glommed-together bindings
    
    109 108
               -- so that we establish the right loop breakers. Otherwise
    
    110 109
               -- we can easily create an infinite loop (#9583 is an example)
    
    111 110
               --
    
    112
    -          -- Also crucial to re-analyse the /original/ bindings
    
    113
    -          -- in case the first pass accidentally discarded as dead code
    
    114
    -          -- a binding that was actually needed (albeit before its
    
    111
    +          -- Also crucial to re-analyse the /original/ bindings, not the
    
    112
    +          -- occ_anald_binds, in case the first pass accidentally discarded as
    
    113
    +          -- dead code a binding that was actually needed (albeit before its
    
    115 114
               -- definition site).  #17724 threw this up.
    
    116 115
     
    
    117 116
         initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)
    
    ... ... @@ -971,16 +970,32 @@ occAnalBind
    971 970
       -> WithUsageDetails r              -- Of the whole let(rec)
    
    972 971
     
    
    973 972
     occAnalBind env lvl ire (Rec pairs) thing_inside combine
    
    974
    -  = addInScopeList env (map fst pairs) $ \env ->
    
    973
    +  = addInScope env (map fst pairs) $ \env ->
    
    975 974
         let WUD body_uds body'  = thing_inside env
    
    976 975
             WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
    
    977 976
         in WUD bind_uds (combine binds' body')
    
    978 977
     
    
    979
    -occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
    
    980
    -  | isTyVar bndr      -- A type let; we don't gather usage info
    
    981
    -  = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside
    
    982
    -    in WUD body_uds (combine [NonRec bndr rhs] res)
    
    978
    +occAnalBind !env _lvl _ire (NonRec bndr rhs) thing_inside combine
    
    979
    +  | isTyCoVar bndr      -- A type/coercion let
    
    980
    +  = let !(WUD body_uds (occ,res))
    
    981
    +             = addInScopeOne env bndr $ \env_body ->
    
    982
    +               let !(WUD inner_uds inner_res) = thing_inside env_body
    
    983
    +                   !tyco_occ = lookupTyCoOcc inner_uds bndr
    
    984
    +               in (WUD inner_uds (tyco_occ, inner_res))
    
    985
    +
    
    986
    +        rhs_tyco_occs = case rhs of
    
    987
    +                           Type ty     -> occAnalTy ty
    
    988
    +                           Coercion co -> occAnalCo co
    
    989
    +                           _ -> pprPanic "occAnalBind" (ppr (NonRec bndr rhs))
    
    990
    +    in
    
    991
    +    case occ of
    
    992
    +      TyCoDead -> WUD body_uds res
    
    993
    +      _        -> WUD (body_uds `addTyCoOccs` rhs_tyco_occs)
    
    994
    +                      (combine [NonRec bndr' rhs] res)
    
    995
    +               where
    
    996
    +                  bndr' = tagTyCoBinder occ bndr
    
    983 997
     
    
    998
    +occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
    
    984 999
       -- /Existing/ non-recursive join points
    
    985 1000
       -- See Note [Occurrence analysis for join points]
    
    986 1001
       | mb_join@(JoinPoint {}) <- idJoinPointHood bndr
    
    ... ... @@ -1134,19 +1149,13 @@ occAnalRec :: OccEnv -> TopLevelFlag
    1134 1149
                -> WithUsageDetails [CoreBind]
    
    1135 1150
     
    
    1136 1151
     -- The NonRec case is just like a Let (NonRec ...) above
    
    1152
    +-- except that type variables can't occur
    
    1137 1153
     occAnalRec !_ lvl
    
    1138 1154
                (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
    
    1139 1155
                (WUD body_uds binds)
    
    1140
    -  -- Currently we don't gather occ-info for tyvars,
    
    1141
    -  -- so we never discard dead bindings -- Need to fix this
    
    1142
    -  | isTyVar bndr
    
    1143
    -  = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
    
    1144
    -        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
    
    1145
    -        !bndr' = tagged_bndr
    
    1146
    -    in WUD (body_uds `andUDs` rhs_uds')
    
    1147
    -           (NonRec bndr' rhs' : binds)
    
    1148
    -
    
    1149
    -  | isDeadOcc occ  -- Check for dead code: see Note [Dead code]
    
    1156
    +  | assertPpr (not (isTyVar bndr)) (ppr bndr) $
    
    1157
    +    -- Rec blocks have no TyVar bindings in them
    
    1158
    +    isDeadOcc occ  -- Check for dead code: see Note [Dead code]
    
    1150 1159
       = WUD body_uds binds
    
    1151 1160
     
    
    1152 1161
       | otherwise
    
    ... ... @@ -1705,7 +1714,7 @@ rank (r, _, _) = r
    1705 1714
     makeNode :: OccEnv -> ImpRuleEdges -> VarSet
    
    1706 1715
              -> (Var, CoreExpr) -> LetrecNode
    
    1707 1716
     -- See Note [Recursive bindings: the grand plan]
    
    1708
    -makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
    
    1717
    +makeNode !_env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
    
    1709 1718
       = -- This is a type binding, e.g.  let @x = Maybe Int in ...
    
    1710 1719
         assert (isTyVar bndr) $
    
    1711 1720
         DigraphNode { node_payload      = details
    
    ... ... @@ -1719,8 +1728,7 @@ makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
    1719 1728
                      , nd_weak_fvs        = emptyVarSet
    
    1720 1729
                      , nd_active_rule_fvs = emptyVarSet }
    
    1721 1730
     
    
    1722
    -    rhs_env = setNonTailCtxt OccRhs env
    
    1723
    -    rhs_uds = occAnalTy rhs_env rhs_ty
    
    1731
    +    rhs_uds = mkTyCoUDs (occAnalTy rhs_ty)
    
    1724 1732
         rhs_fvs = udFreeVars bndr_set rhs_uds
    
    1725 1733
     
    
    1726 1734
     makeNode !env imp_rule_edges bndr_set (bndr, rhs)
    
    ... ... @@ -2229,9 +2237,9 @@ occ_anal_lam_tail env (Cast expr co)
    2229 2237
       = let  WUD expr_uds expr' = occ_anal_lam_tail env expr
    
    2230 2238
     
    
    2231 2239
              -- co_uds: see Note [Gather occurrences of coercion variables]
    
    2232
    -         co_uds = occAnalCo env co
    
    2240
    +         co_uds = occAnalCo co
    
    2233 2241
     
    
    2234
    -         usage1 = expr_uds `andUDs` co_uds
    
    2242
    +         usage1 = expr_uds `addTyCoOccs` co_uds
    
    2235 2243
     
    
    2236 2244
              -- usage2: see Note [Occ-anal and cast worker/wrapper]
    
    2237 2245
              usage2 = case expr of
    
    ... ... @@ -2436,14 +2444,54 @@ float ==>
    2436 2444
     This is worse than the slow cascade, so we only want to say "certainly_inline"
    
    2437 2445
     if it really is certain.  Look at the note with preInlineUnconditionally
    
    2438 2446
     for the various clauses.  See #24582 for an example of the two getting out of sync.
    
    2447
    +-}
    
    2448
    +
    
    2449
    +{- *********************************************************************
    
    2450
    +*                                                                      *
    
    2451
    +                Types
    
    2452
    +*                                                                      *
    
    2453
    +********************************************************************* -}
    
    2439 2454
     
    
    2455
    +newtype TyCoOccs = TyCoOccs { get_tyco_occs :: TyCoOccEnv }
    
    2440 2456
     
    
    2441
    -************************************************************************
    
    2457
    +instance S.Semigroup TyCoOccs where
    
    2458
    +  (TyCoOccs o1) <> (TyCoOccs o2) = TyCoOccs (plusTyCoOccEnv o1 o2)
    
    2459
    +
    
    2460
    +instance S.Monoid TyCoOccs where
    
    2461
    +  mempty = TyCoOccs emptyVarEnv
    
    2462
    +
    
    2463
    +occTyCoFolder :: TyCoFolder TyCoVarSet TyCoOccs
    
    2464
    +occTyCoFolder
    
    2465
    +  = TyCoFolder { tcf_view  = \_ -> Nothing   -- No need to expand synonyms
    
    2466
    +               , tcf_tyvar = do_var
    
    2467
    +               , tcf_covar = do_var
    
    2468
    +               , tcf_hole  = \_ h -> pprPanic "occTyCoFolder:hole" (ppr h)
    
    2469
    +               , tcf_tycobinder = do_binder }
    
    2470
    +  where
    
    2471
    +    do_var :: TyCoVarSet -> TyCoVar -> TyCoOccs
    
    2472
    +    do_var locals tcv
    
    2473
    +      | tcv `elemVarSet` locals      = mempty
    
    2474
    +      | isExternalName (varName tcv) = mempty  -- TyVars from other modules
    
    2475
    +      | otherwise                    = TyCoOccs (unitVarEnv tcv TyCoOne)
    
    2476
    +
    
    2477
    +    do_binder :: TyCoVarSet -> TyCoVar -> ForAllTyFlag -> TyCoVarSet
    
    2478
    +    do_binder locals tcv _ = extendVarSet locals tcv
    
    2479
    +
    
    2480
    +occAnalTy  :: Type -> TyCoOccEnv
    
    2481
    +occAnalCo  :: Coercion -> TyCoOccEnv
    
    2482
    +occAnalTy ty = get_tyco_occs (occ_anal_ty ty)
    
    2483
    +occAnalCo co = get_tyco_occs (occ_anal_co co)
    
    2484
    +
    
    2485
    +occ_anal_ty  :: Type -> TyCoOccs
    
    2486
    +occ_anal_co  :: Coercion -> TyCoOccs
    
    2487
    +(occ_anal_ty, _, occ_anal_co, _) = foldTyCo occTyCoFolder emptyVarSet
    
    2488
    +-- No need to return a modified type, unlike expressions
    
    2489
    +
    
    2490
    +{- *********************************************************************
    
    2442 2491
     *                                                                      *
    
    2443 2492
                     Expressions
    
    2444 2493
     *                                                                      *
    
    2445
    -************************************************************************
    
    2446
    --}
    
    2494
    +********************************************************************* -}
    
    2447 2495
     
    
    2448 2496
     occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
    
    2449 2497
     occAnalList !_   []    = WUD emptyDetails []
    
    ... ... @@ -2452,50 +2500,6 @@ occAnalList env (e:es) = let
    2452 2500
                               (WUD uds2 es') = occAnalList env es
    
    2453 2501
                              in WUD (uds1 `andUDs` uds2) (e' : es')
    
    2454 2502
     
    
    2455
    -occAnalTys :: OccEnv -> [Type] -> UsageDetails
    
    2456
    -occAnalTys env tys = foldr (andUDs . occAnalTy env) emptyDetails tys
    
    2457
    -
    
    2458
    -occAnalTy :: OccEnv -> Type -> UsageDetails
    
    2459
    --- No need to return a modified type, unlike expressions
    
    2460
    -occAnalTy env (TyVarTy tv)              = mkOneTyVarOcc env tv
    
    2461
    -occAnalTy _   (LitTy {})                = emptyDetails
    
    2462
    -occAnalTy env (AppTy t1 t2)             = occAnalTy env t1 `andUDs` occAnalTy env t2
    
    2463
    -occAnalTy env (CastTy ty co)            = occAnalTy env ty `andUDs` occAnalCo env co
    
    2464
    -occAnalTy env (CoercionTy co)           = occAnalCo env co
    
    2465
    -occAnalTy env (TyConApp _ tys)          = occAnalTys env tys
    
    2466
    -occAnalTy env (ForAllTy (Bndr tv _) ty) = delBndrsFromUDs [tv] (occAnalTy env ty)
    
    2467
    -occAnalTy env (FunTy { ft_mult = w, ft_arg = arg, ft_res = res })
    
    2468
    -  = occAnalTy env w `andUDs` occAnalTy env arg `andUDs` occAnalTy env res
    
    2469
    -
    
    2470
    -occAnalCos :: OccEnv -> [Coercion] -> UsageDetails
    
    2471
    -occAnalCos env cos = foldr (andUDs . occAnalCo env) emptyDetails cos
    
    2472
    -
    
    2473
    -occAnalMCo :: OccEnv -> MCoercion -> UsageDetails
    
    2474
    -occAnalMCo _   MRefl    = emptyDetails
    
    2475
    -occAnalMCo env (MCo co) = occAnalCo env co
    
    2476
    -
    
    2477
    -occAnalCo :: OccEnv -> Coercion -> UsageDetails
    
    2478
    -occAnalCo !env (Refl ty)           = occAnalTy env ty
    
    2479
    -occAnalCo !env (GRefl _ ty mco)    = occAnalTy env ty `andUDs` occAnalMCo env mco
    
    2480
    -occAnalCo !env (AppCo co1 co2)     = occAnalCo env co1 `andUDs` occAnalCo env co2
    
    2481
    -occAnalCo env (CoVarCo cv)         = mkOneIdOcc env cv NotInteresting 0
    
    2482
    -occAnalCo _ (HoleCo hole)          = pprPanic "occAnalCo:HoleCo" (ppr hole)
    
    2483
    -occAnalCo env (SymCo co)           = occAnalCo env co
    
    2484
    -occAnalCo env (TransCo co1 co2)    = occAnalCo env co1 `andUDs` occAnalCo env co2
    
    2485
    -occAnalCo env (AxiomCo _ cos)      = occAnalCos env cos
    
    2486
    -occAnalCo env (SelCo _ co)         = occAnalCo env co
    
    2487
    -occAnalCo env (LRCo _ co)          = occAnalCo env co
    
    2488
    -occAnalCo env (InstCo co arg)      = occAnalCo env co `andUDs` occAnalCo env arg
    
    2489
    -occAnalCo env (KindCo co)          = occAnalCo env co
    
    2490
    -occAnalCo env (SubCo co)           = occAnalCo env co
    
    2491
    -occAnalCo env (TyConAppCo _ _ cos) = occAnalCos env cos
    
    2492
    -occAnalCo !env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })
    
    2493
    -  = occAnalCo env cw `andUDs` occAnalCo env c1 `andUDs` occAnalCo env c2
    
    2494
    -occAnalCo env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos })
    
    2495
    -  = occAnalTy env t1 `andUDs` occAnalTy env t2 `andUDs` occAnalCos env cos
    
    2496
    -occAnalCo env (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co })
    
    2497
    -  = occAnalCo env kind_co `andUDs` delBndrsFromUDs [tv] (occAnalCo env co)
    
    2498
    -
    
    2499 2503
     occAnal :: OccEnv
    
    2500 2504
             -> CoreExpr
    
    2501 2505
             -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids
    
    ... ... @@ -2510,8 +2514,8 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], [])
    2510 2514
         -- rules in them, so the *specialised* versions looked as if they
    
    2511 2515
         -- weren't used at all.
    
    2512 2516
     
    
    2513
    -occAnal env (Type ty)     = WUD (occAnalTy env ty) (Type ty)
    
    2514
    -occAnal env (Coercion co) = WUD (occAnalCo env co) (Coercion co)
    
    2517
    +occAnal _env (Type ty)     = WUD (mkTyCoUDs (occAnalTy ty)) (Type ty)
    
    2518
    +occAnal _env (Coercion co) = WUD (mkTyCoUDs (occAnalCo co)) (Coercion co)
    
    2515 2519
     
    
    2516 2520
     {- Note [Gather occurrences of coercion variables]
    
    2517 2521
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ... ... @@ -2589,10 +2593,10 @@ occAnal env (Tick tickish body)
    2589 2593
     
    
    2590 2594
     occAnal env (Cast expr co)
    
    2591 2595
       = let  (WUD expr_uds expr') = occAnal env expr
    
    2592
    -         co_uds = occAnalCo env co
    
    2596
    +         co_uds = occAnalCo co
    
    2593 2597
                  -- co_uds: see Note [Gather occurrences of coercion variables]
    
    2594
    -         uds = markAllNonTail (expr_uds `andUDs` co_uds)
    
    2595
    -             -- co_uds': calls inside expr aren't tail calls any more
    
    2598
    +         uds = markAllNonTail (expr_uds `addTyCoOccs` co_uds)
    
    2599
    +             -- markAllNonTail: calls inside expr aren't tail calls any more
    
    2596 2600
         in WUD uds (Cast expr' co)
    
    2597 2601
     
    
    2598 2602
     occAnal env app@(App _ _)
    
    ... ... @@ -2614,7 +2618,9 @@ occAnal env (Case scrut bndr ty alts)
    2614 2618
                    tagged_bndr = tagLamBinder alts_usage bndr
    
    2615 2619
                in WUD alts_usage (tagged_bndr, alts')
    
    2616 2620
     
    
    2617
    -      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage
    
    2621
    +      total_usage = markAllNonTail scrut_usage
    
    2622
    +                    `andUDs` alts_usage
    
    2623
    +                    `addTyCoOccs` occAnalTy ty
    
    2618 2624
                         -- Alts can have tail calls, but the scrutinee can't
    
    2619 2625
     
    
    2620 2626
         in WUD total_usage (Case scrut' tagged_bndr ty alts')
    
    ... ... @@ -2719,7 +2725,7 @@ occAnalApp !env (Var fun, args, ticks)
    2719 2725
     occAnalApp env (Var fun_id, args, ticks)
    
    2720 2726
       = WUD all_uds (mkTicks ticks app')
    
    2721 2727
       where
    
    2722
    -    -- Lots of banged bindings: this is a very heavily bit of code,
    
    2728
    +    -- Lots of banged bindings: this is a very heavily used bit of code,
    
    2723 2729
         -- so it pays not to make lots of thunks here, all of which
    
    2724 2730
         -- will ultimately be forced.
    
    2725 2731
         !(fun', fun_id')  = lookupBndrSwap env fun_id
    
    ... ... @@ -3136,24 +3142,23 @@ addInScope :: OccEnv -> [Var]
    3136 3142
     -- We do not assume that the bndrs are in scope order; in fact the
    
    3137 3143
     -- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order
    
    3138 3144
     
    
    3139
    --- Fast path when the is no environment-munging to do
    
    3140
    --- This is rather common: notably at top level, but nested too
    
    3141 3145
     addInScope env bndrs thing_inside
    
    3142 3146
       | null bndrs   -- E.g. nullary constructors in a `case`
    
    3143 3147
       = thing_inside env
    
    3144 3148
     
    
    3149
    +  -- Fast path when the is no environment-munging to do
    
    3150
    +  -- This is rather common: notably at top level, but nested too
    
    3145 3151
       | isEmptyVarEnv (occ_bs_env env)
    
    3146 3152
       , isEmptyVarEnv (occ_join_points env)
    
    3147 3153
       , WUD uds res <- thing_inside env
    
    3148 3154
       = WUD (delBndrsFromUDs bndrs uds) res
    
    3149 3155
     
    
    3150
    -addInScope env bndrs thing_inside
    
    3156
    +  -- Normal path
    
    3157
    +  | let !(env', bad_joins) = preprocess_env env bndr_set
    
    3158
    +        !(WUD uds res)     = thing_inside env'
    
    3159
    +        uds'               = postprocess_uds bndrs bad_joins uds
    
    3160
    +        bndr_set           = mkVarSet bndrs
    
    3151 3161
       = WUD uds' res
    
    3152
    -  where
    
    3153
    -    bndr_set           = mkVarSet bndrs
    
    3154
    -    !(env', bad_joins) = preprocess_env env bndr_set
    
    3155
    -    !(WUD uds res)     = thing_inside env'
    
    3156
    -    uds'               = postprocess_uds bndrs bad_joins uds
    
    3157 3162
     
    
    3158 3163
     preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
    
    3159 3164
     preprocess_env env@(OccEnv { occ_join_points = join_points
    
    ... ... @@ -3668,8 +3673,8 @@ For example, in (case x of A -> y; B -> y; C -> True),
    3668 3673
     
    
    3669 3674
     -}
    
    3670 3675
     
    
    3671
    -type IdOccEnv = VarEnv LocalOcc        -- A finite map from an expression's
    
    3672
    -                                         -- free variables to their usage
    
    3676
    +type IdOccEnv = IdEnv LocalOcc        -- A finite map from an expression's
    
    3677
    +                                       -- free variables to their usage
    
    3673 3678
     
    
    3674 3679
     data LocalOcc  -- See Note [LocalOcc]
    
    3675 3680
          = OneOccL { lo_n_br  :: {-# UNPACK #-} !BranchCount  -- Number of syntactic occurrences
    
    ... ... @@ -3690,9 +3695,7 @@ localTailCallInfo (ManyOccL tci) = tci
    3690 3695
     
    
    3691 3696
     -- For TyVars and CoVars we gather only whether it occurs once or
    
    3692 3697
     -- many times; we aren't interested in case-branches or tail-calls
    
    3693
    -data TyCoOccEnv = VarEnv TyCoOcc
    
    3694
    -
    
    3695
    -data TyCoOcc = OneOccTyCo | ManyOccTyCo
    
    3698
    +type TyCoOccEnv = TyCoVarEnv TyCoOccInfo
    
    3696 3699
     
    
    3697 3700
     type ZappedSet     = IdOccEnv
    
    3698 3701
     type ZappedTyCoSet = TyCoOccEnv
    
    ... ... @@ -3704,24 +3707,19 @@ data UsageDetails
    3704 3707
            , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these
    
    3705 3708
            , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these
    
    3706 3709
            , ud_z_tail    :: !ZappedSet   -- zap tail-call info for these
    
    3710
    +
    
    3707 3711
            , ud_tyco_env  :: !TyCoOccEnv
    
    3708
    -       , ud_z_tyzo    :: !ZappedTyCoSet
    
    3712
    +       , ud_z_tyco    :: !ZappedTyCoSet  -- These ones occur many times
    
    3709 3713
            }
    
    3710 3714
       -- INVARIANT: `ud_z_many`, `ud_z_in_lam` and `ud_z_tail`
    
    3711
    -o  --             are all subsets of ud_id_env
    
    3712
    -  --            `ud_z_tyco` is a subset of ud_tycon_env
    
    3715
    +  --             are all subsets of ud_id_env
    
    3716
    +  --            `ud_z_tyco` is a subset of ud_tyco_env
    
    3713 3717
     
    
    3714 3718
     instance Outputable UsageDetails where
    
    3715
    -  ppr ud@(UD { ud_id_env = env, ud_tyco_env = tyco_env })
    
    3716
    -    = text "UD" <+> (braces $ fsep $ punctuate comma $
    
    3717
    -        [ ppr uq <+> text ":->" <+> ppr (lookupOccByUnique ud uq)
    
    3718
    -        | uq <- nonDetStrictFoldVarEnv_Directly do_one [] id_env ]
    
    3719
    -        ++
    
    3720
    -        [ ppr uq <+> text ":->" <+> ppr (lookupTyCoOccByUnique ud uq)
    
    3721
    -        | uq <- nonDetStrictFoldVarEnv_Directly do_one [] tyco_env ])
    
    3722
    -    where
    
    3723
    -      do_one :: Unique -> a -> [Unique] -> [Unique]
    
    3724
    -      do_one uniq _ uniqs = uniq : uniqs
    
    3719
    +  ppr (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
    
    3720
    +    = text "UD" <+> (braces $ vcat
    
    3721
    +        [ text "ud_id_env =" <+> ppr id_env
    
    3722
    +        , text "ud_tyco_env =" <+> ppr tyco_env ])
    
    3725 3723
     
    
    3726 3724
     ---------------------
    
    3727 3725
     -- | TailUsageDetails captures the result of applying 'occAnalLamTail'
    
    ... ... @@ -3743,18 +3741,13 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a
    3743 3741
     -------------------
    
    3744 3742
     -- UsageDetails API
    
    3745 3743
     
    
    3746
    -andUDs, orUDs
    
    3747
    -        :: UsageDetails -> UsageDetails -> UsageDetails
    
    3744
    +plusTyCoOccEnv :: TyCoOccEnv -> TyCoOccEnv -> TyCoOccEnv
    
    3745
    +plusTyCoOccEnv env1 env2 = plusVarEnv_C plusTyCoOccInfo env1 env2
    
    3746
    +
    
    3747
    +andUDs, orUDs :: UsageDetails -> UsageDetails -> UsageDetails
    
    3748 3748
     andUDs = combineUsageDetailsWith andLocalOcc
    
    3749 3749
     orUDs  = combineUsageDetailsWith orLocalOcc
    
    3750 3750
     
    
    3751
    -mkOneTyVarOcc :: OccEnv -> TyVar -> UsageDetails
    
    3752
    -mkOneTyVarOcc !_env tv
    
    3753
    -  = mkSimpleDetails (unitVarEnv tv occ)
    
    3754
    -  where
    
    3755
    -    occ = OneOccL { lo_n_br = 1, lo_int_cxt = NotInteresting
    
    3756
    -                  , lo_tail = NoTailCallInfo }
    
    3757
    -
    
    3758 3751
     mkOneIdOcc :: OccEnv -> Var -> InterestingCxt -> JoinArity -> UsageDetails
    
    3759 3752
     mkOneIdOcc !env id int_cxt arity
    
    3760 3753
       | assert (not (isTyVar id)) $
    
    ... ... @@ -3765,10 +3758,10 @@ mkOneIdOcc !env id int_cxt arity
    3765 3758
       = -- See Note [Occurrence analysis for join points]
    
    3766 3759
         assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $
    
    3767 3760
            -- We only put non-empty join-points into occ_join_points
    
    3768
    -    mkSimpleDetails (extendVarEnv join_uds id occ)
    
    3761
    +    mkIdUDs (extendVarEnv join_uds id occ)
    
    3769 3762
     
    
    3770 3763
       | otherwise
    
    3771
    -  = mkSimpleDetails (unitVarEnv id occ)
    
    3764
    +  = mkIdUDs (unitVarEnv id occ)
    
    3772 3765
     
    
    3773 3766
       where
    
    3774 3767
         occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt
    
    ... ... @@ -3786,11 +3779,15 @@ add_many_occ v env = extendVarEnv env v (ManyOccL NoTailCallInfo)
    3786 3779
     addManyOccs :: UsageDetails -> VarSet -> UsageDetails
    
    3787 3780
     addManyOccs uds var_set
    
    3788 3781
       | isEmptyVarSet var_set = uds
    
    3789
    -  | otherwise             = uds { ud_env = add_to (ud_env uds) }
    
    3782
    +  | otherwise             = uds { ud_id_env = add_to (ud_id_env uds) }
    
    3790 3783
       where
    
    3791 3784
         add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set
    
    3792 3785
         -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes
    
    3793 3786
     
    
    3787
    +addTyCoOccs :: UsageDetails -> TyCoOccEnv -> UsageDetails
    
    3788
    +addTyCoOccs uds@(UD { ud_tyco_env = env}) extras
    
    3789
    +  = uds { ud_tyco_env = env `plusTyCoOccEnv` extras }
    
    3790
    +
    
    3794 3791
     addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
    
    3795 3792
     -- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var]
    
    3796 3793
     -- Add any TyCoVars free in the type of a lambda-binder
    
    ... ... @@ -3801,39 +3798,52 @@ addLamTyCoVarOccs uds bndrs
    3801 3798
         add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr)
    
    3802 3799
     
    
    3803 3800
     emptyDetails :: UsageDetails
    
    3804
    -emptyDetails = mkSimpleDetails emptyVarEnv
    
    3801
    +emptyDetails = UD { ud_id_env   = emptyVarEnv
    
    3802
    +                  , ud_z_many   = emptyVarEnv
    
    3803
    +                  , ud_z_in_lam = emptyVarEnv
    
    3804
    +                  , ud_z_tail   = emptyVarEnv
    
    3805
    +                  , ud_tyco_env = emptyVarEnv
    
    3806
    +                  , ud_z_tyco   = emptyVarEnv }
    
    3805 3807
     
    
    3806 3808
     isEmptyDetails :: UsageDetails -> Bool
    
    3807
    -isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env
    
    3809
    +isEmptyDetails (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
    
    3810
    +  = isEmptyVarEnv id_env && isEmptyVarEnv tyco_env
    
    3811
    +
    
    3812
    +mkIdUDs :: IdOccEnv -> UsageDetails
    
    3813
    +mkIdUDs env = emptyDetails { ud_id_env = env }
    
    3808 3814
     
    
    3809
    -mkSimpleDetails :: IdOccEnv -> UsageDetails
    
    3810
    -mkSimpleDetails env = UD { ud_env       = env
    
    3811
    -                         , ud_z_many    = emptyVarEnv
    
    3812
    -                         , ud_z_in_lam  = emptyVarEnv
    
    3813
    -                         , ud_z_tail    = emptyVarEnv }
    
    3815
    +mkTyCoUDs :: TyCoOccEnv -> UsageDetails
    
    3816
    +mkTyCoUDs env = emptyDetails { ud_tyco_env = env }
    
    3814 3817
     
    
    3815 3818
     modifyUDEnv :: (IdOccEnv -> IdOccEnv) -> UsageDetails -> UsageDetails
    
    3816
    -modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }
    
    3819
    +modifyUDEnv f uds@(UD { ud_id_env = env }) = uds { ud_id_env = f env }
    
    3817 3820
     
    
    3818 3821
     delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails
    
    3819 3822
     -- Delete these binders from the UsageDetails
    
    3820
    --- But /add/ the free vars of the types
    
    3821
    -delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many
    
    3822
    -                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail })
    
    3823
    -  = UD { ud_env       = env      `delVarEnvList` bndrs
    
    3823
    +-- But /add/ the free vars of the types.  That may seem odd, but this is
    
    3824
    +-- a very convenient place to do it!
    
    3825
    +delBndrsFromUDs bndrs (UD { ud_id_env = env, ud_z_many = z_many
    
    3826
    +                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail
    
    3827
    +                          , ud_tyco_env = tyco_env, ud_z_tyco = z_tyco })
    
    3828
    +  = UD { ud_id_env    = env      `delVarEnvList` bndrs
    
    3824 3829
            , ud_z_many    = z_many   `delVarEnvList` bndrs
    
    3825 3830
            , ud_z_in_lam  = z_in_lam `delVarEnvList` bndrs
    
    3826
    -       , ud_z_tail    = z_tail   `delVarEnvList` bndrs }
    
    3831
    +       , ud_z_tail    = z_tail   `delVarEnvList` bndrs
    
    3832
    +       , ud_tyco_env  = adjust bndrs tyco_env
    
    3833
    +       , ud_z_tyco    = z_tyco   `delVarEnvList` bndrs
    
    3834
    +       }
    
    3827 3835
       where
    
    3828
    -    ty_fvs []     = emptyVarSet
    
    3829
    -    ty_fvs (b:bs) = tyCoVarsOfType b `unionVarSet`
    
    3830
    -                    (ty_fvs bs `delVarSet` b)
    
    3836
    +    adjust :: [Var] -> TyCoOccEnv -> TyCoOccEnv
    
    3837
    +    -- Delete binders, but add the free vars of their types
    
    3838
    +    adjust []     env = env
    
    3839
    +    adjust (b:bs) env = occAnalTy (varType b) `plusTyCoOccEnv`
    
    3840
    +                        (adjust bs env `delVarEnv` b)
    
    3831 3841
     
    
    3832 3842
     markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
    
    3833 3843
       :: UsageDetails -> UsageDetails
    
    3834
    -markAllMany      ud@(UD { ud_env = env }) = ud { ud_z_many   = env }
    
    3835
    -markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }
    
    3836
    -markAllNonTail   ud@(UD { ud_env = env }) = ud { ud_z_tail   = env }
    
    3844
    +markAllMany      ud@(UD { ud_id_env = env }) = ud { ud_z_many   = env }
    
    3845
    +markAllInsideLam ud@(UD { ud_id_env = env }) = ud { ud_z_in_lam = env }
    
    3846
    +markAllNonTail   ud@(UD { ud_id_env = env }) = ud { ud_z_tail   = env }
    
    3837 3847
     markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
    
    3838 3848
     
    
    3839 3849
     markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
    
    ... ... @@ -3846,7 +3856,7 @@ markAllNonTailIf False ud = ud
    3846 3856
     
    
    3847 3857
     lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
    
    3848 3858
     lookupTailCallInfo uds id
    
    3849
    -  | UD { ud_z_tail = z_tail, ud_env = env } <- uds
    
    3859
    +  | UD { ud_z_tail = z_tail, ud_id_env = env } <- uds
    
    3850 3860
       , not (id `elemVarEnv` z_tail)
    
    3851 3861
       , Just occ <- lookupVarEnv env id
    
    3852 3862
       = localTailCallInfo occ
    
    ... ... @@ -3855,9 +3865,10 @@ lookupTailCallInfo uds id
    3855 3865
     
    
    3856 3866
     udFreeVars :: VarSet -> UsageDetails -> VarSet
    
    3857 3867
     -- Find the subset of bndrs that are mentioned in uds
    
    3858
    -udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env
    
    3868
    +udFreeVars bndrs (UD { ud_id_env = id_env, ud_tyco_env = tyco_env })
    
    3869
    +  = restrictFreeVars bndrs id_env `unionVarSet` restrictFreeVars bndrs tyco_env
    
    3859 3870
     
    
    3860
    -restrictFreeVars :: VarSet -> IdOccEnv -> VarSet
    
    3871
    +restrictFreeVars :: VarSet -> VarEnv a -> VarSet
    
    3861 3872
     restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
    
    3862 3873
     
    
    3863 3874
     -------------------
    
    ... ... @@ -3867,15 +3878,19 @@ combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)
    3867 3878
                             -> UsageDetails -> UsageDetails -> UsageDetails
    
    3868 3879
     {-# INLINE combineUsageDetailsWith #-}
    
    3869 3880
     combineUsageDetailsWith plus_occ_info
    
    3870
    -    uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })
    
    3871
    -    uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })
    
    3872
    -  | isEmptyVarEnv env1 = uds2
    
    3873
    -  | isEmptyVarEnv env2 = uds1
    
    3881
    +    uds1@(UD { ud_id_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1
    
    3882
    +             , ud_tyco_env = tyco_env1, ud_z_tyco = z_tyco1 })
    
    3883
    +    uds2@(UD { ud_id_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2
    
    3884
    +             , ud_tyco_env = tyco_env2, ud_z_tyco = z_tyco2 })
    
    3885
    +  | isEmptyDetails uds1 = uds2
    
    3886
    +  | isEmptyDetails uds2 = uds1
    
    3874 3887
       | otherwise
    
    3875
    -  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2
    
    3876
    -       , ud_z_many    = plusVarEnv z_many1   z_many2
    
    3877
    -       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2
    
    3878
    -       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }
    
    3888
    +  = UD { ud_id_env   = plusVarEnv_C plus_occ_info env1 env2
    
    3889
    +       , ud_z_many   = plusVarEnv z_many1   z_many2
    
    3890
    +       , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2
    
    3891
    +       , ud_z_tail   = plusVarEnv z_tail1   z_tail2
    
    3892
    +       , ud_tyco_env = plusTyCoOccEnv tyco_env1 tyco_env2
    
    3893
    +       , ud_z_tyco   = plusVarEnv z_tyco1 z_tyco2 }
    
    3879 3894
     
    
    3880 3895
     lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
    
    3881 3896
     -- Don't use locally-generated occ_info for exported (visible-elsewhere)
    
    ... ... @@ -3884,21 +3899,24 @@ lookupLetOccInfo :: UsageDetails -> Id -> OccInfo
    3884 3899
     --     we are about to re-generate it and it shouldn't be "sticky"
    
    3885 3900
     lookupLetOccInfo ud id
    
    3886 3901
      | isExportedId id = noOccInfo
    
    3887
    - | otherwise       = lookupOccByUnique ud (idUnique id)
    
    3902
    + | otherwise       = lookupIdOccByUnique ud (idUnique id)
    
    3903
    +
    
    3904
    +lookupIdOccInfo :: UsageDetails -> Id -> OccInfo
    
    3905
    +lookupIdOccInfo ud id = lookupIdOccByUnique ud (idUnique id)
    
    3888 3906
     
    
    3889
    -lookupOccInfo :: UsageDetails -> Id -> OccInfo
    
    3890
    -lookupOccInfo ud id = lookupOccByUnique ud (idUnique id)
    
    3907
    +lookupTyCoOcc :: UsageDetails -> TyCoVar -> TyCoOccInfo
    
    3908
    +lookupTyCoOcc uds tcv = lookupTyCoOccByUnique uds (varUnique tcv)
    
    3891 3909
     
    
    3892
    -lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOcc
    
    3893
    -lookupTyCoByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq
    
    3910
    +lookupTyCoOccByUnique :: UsageDetails -> Unique -> TyCoOccInfo
    
    3911
    +lookupTyCoOccByUnique (UD { ud_tyco_env = env, ud_z_tyco = z_tyco }) uniq
    
    3894 3912
       = case lookupVarEnv_Directly env uniq of
    
    3895
    -      Nothing -> Nothing
    
    3896
    -      Just ManyOccTyCo -> Just ManyOccTyCo
    
    3897
    -      Just OneOccTyCo | uniq `elemVarEnvByKey` z_tyco = Just ManyOccTyCo
    
    3898
    -                      | otherwise                     = Just OneOccTyCo
    
    3913
    +      Nothing -> TyCoDead
    
    3914
    +      Just TyCoOne | uniq `elemVarEnvByKey` z_tyco -> TyCoMany
    
    3915
    +                   | otherwise                     -> TyCoOne
    
    3916
    +      Just occ -> occ
    
    3899 3917
     
    
    3900
    -lookupOccByUnique :: UsageDetails -> Unique -> OccInfo
    
    3901
    -lookupOccByUnique (UD { ud_env       = env
    
    3918
    +lookupIdOccByUnique :: UsageDetails -> Unique -> OccInfo
    
    3919
    +lookupIdOccByUnique (UD { ud_id_env    = env
    
    3902 3920
                           , ud_z_many    = z_many
    
    3903 3921
                           , ud_z_in_lam  = z_in_lam
    
    3904 3922
                           , ud_z_tail    = z_tail })
    
    ... ... @@ -3925,6 +3943,12 @@ lookupOccByUnique (UD { ud_env = env
    3925 3943
             | otherwise                     = ti
    
    3926 3944
     
    
    3927 3945
     
    
    3946
    +tyCoOccToIdOcc :: TyCoOccInfo -> OccInfo
    
    3947
    +-- Used for CoVars
    
    3948
    +tyCoOccToIdOcc TyCoDead = IAmDead
    
    3949
    +tyCoOccToIdOcc TyCoOne  = OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1
    
    3950
    +                                 , occ_int_cxt = NotInteresting, occ_tail = NoTailCallInfo }
    
    3951
    +tyCoOccToIdOcc TyCoMany = noOccInfo
    
    3928 3952
     
    
    3929 3953
     -------------------
    
    3930 3954
     -- See Note [Adjusting right-hand sides]
    
    ... ... @@ -3958,34 +3982,42 @@ adjustTailArity mb_rhs_ja (TUD ja usage)
    3958 3982
     type IdWithOccInfo = Id
    
    3959 3983
     
    
    3960 3984
     tagLamBinders :: UsageDetails        -- Of scope
    
    3961
    -              -> [Id]                -- Binders
    
    3985
    +              -> [CoreBndr]          -- Binders
    
    3962 3986
                   -> [IdWithOccInfo]     -- Tagged binders
    
    3963 3987
     tagLamBinders usage binders
    
    3964 3988
       = map (tagLamBinder usage) binders
    
    3965 3989
     
    
    3966 3990
     tagLamBinder :: UsageDetails       -- Of scope
    
    3967
    -             -> Id                 -- Binder
    
    3991
    +             -> CoreBndr           -- Binder
    
    3968 3992
                  -> IdWithOccInfo      -- Tagged binders
    
    3969 3993
     -- Used for lambda and case binders
    
    3970
    --- No-op on TyVars
    
    3994
    +-- No-op on TyVars; we could tag them but not much point
    
    3971 3995
     -- A lambda binder never has an unfolding, so no need to look for that
    
    3972 3996
     tagLamBinder usage bndr
    
    3973
    -  = setBinderOcc (markNonTail occ) bndr
    
    3997
    +  | isTyCoVar bndr
    
    3998
    +  = bndr
    
    3999
    +  | otherwise
    
    4000
    +  = setIdBinderOcc (markNonTail occ) bndr
    
    3974 4001
           -- markNonTail: don't try to make an argument into a join point
    
    3975 4002
       where
    
    3976
    -    occ = lookupOccInfo usage bndr
    
    4003
    +    occ = lookupIdOccInfo usage bndr
    
    4004
    +
    
    4005
    +tagTyCoBinder :: TyCoOccInfo -> TyCoVar -> TyCoVar
    
    4006
    +tagTyCoBinder occ bndr
    
    4007
    +  | isId bndr = setIdOccInfo bndr (tyCoOccToIdOcc occ)
    
    4008
    +  | otherwise = setTyVarOccInfo bndr occ
    
    3977 4009
     
    
    3978 4010
     tagNonRecBinder :: TopLevelFlag           -- At top level?
    
    3979 4011
                     -> OccInfo                -- Of scope
    
    3980
    -                -> CoreBndr               -- Binder
    
    4012
    +                -> Id                     -- Binder
    
    3981 4013
                     -> (IdWithOccInfo, JoinPointHood)  -- Tagged binder
    
    3982 4014
     -- Precondition: OccInfo is not IAmDead
    
    3983 4015
     tagNonRecBinder lvl occ bndr
    
    3984 4016
       | okForJoinPoint lvl bndr tail_call_info
    
    3985 4017
       , AlwaysTailCalled ar <- tail_call_info
    
    3986
    -  = (setBinderOcc occ bndr,        JoinPoint ar)
    
    4018
    +  = (setIdBinderOcc occ bndr,        JoinPoint ar)
    
    3987 4019
       | otherwise
    
    3988
    -  = (setBinderOcc zapped_occ bndr, NotJoinPoint)
    
    4020
    +  = (setIdBinderOcc zapped_occ bndr, NotJoinPoint)
    
    3989 4021
      where
    
    3990 4022
         tail_call_info = tailCallInfo occ
    
    3991 4023
         zapped_occ     = markNonTail occ
    
    ... ... @@ -4035,18 +4067,17 @@ tagRecBinders lvl body_uds details_s
    4035 4067
          adj_uds = foldr andUDs body_uds rhs_udss'
    
    4036 4068
     
    
    4037 4069
          -- 4. Tag each binder with its adjusted details
    
    4038
    -     bndrs'    = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr
    
    4070
    +     bndrs'    = [ setIdBinderOcc (lookupLetOccInfo adj_uds bndr) bndr
    
    4039 4071
                      | bndr <- bndrs ]
    
    4040 4072
     
    
    4041 4073
        in
    
    4042 4074
        WUD adj_uds bndrs'
    
    4043 4075
     
    
    4044
    -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
    
    4045
    -setBinderOcc occ_info bndr
    
    4046
    -  | isTyVar bndr = if (occ_info == tyVarOccInfo bndr) then bndr
    
    4047
    -                   else setTyVarOccInfo bndr occ_info
    
    4048
    -  | otherwise    = if (occ_info == idOccInfo bndr) then bndr
    
    4049
    -                   else setIdOccInfo bndr occ_info
    
    4076
    +setIdBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
    
    4077
    +setIdBinderOcc occ_info bndr
    
    4078
    +  = assertPpr (isNonCoVarId bndr) (ppr bndr) $
    
    4079
    +    if (occ_info == idOccInfo bndr) then bndr
    
    4080
    +    else setIdOccInfo bndr occ_info
    
    4050 4081
     
    
    4051 4082
     -- | Decide whether some bindings should be made into join points or not, based
    
    4052 4083
     -- on its occurrences. This is
    

  • compiler/GHC/Core/Opt/Simplify.hs
    ... ... @@ -441,8 +441,8 @@ type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks
    441 441
     shortOutIndirections :: CoreProgram -> CoreProgram
    
    442 442
     shortOutIndirections binds
    
    443 443
       | isEmptyVarEnv ind_env = binds
    
    444
    -  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirection-zapping]
    
    445
    -  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
    
    444
    +  | no_need_to_flatten    = binds'              -- See Note [Rules and indirection-zapping]
    
    445
    +  | otherwise             = glomValBinds binds' -- for this no_need_to_flatten stuff
    
    446 446
       where
    
    447 447
         ind_env            = makeIndEnv binds
    
    448 448
         -- These exported Ids are the subjects  of the indirection-elimination
    

  • compiler/GHC/Core/Opt/Simplify/Env.hs
    ... ... @@ -930,22 +930,19 @@ mkRecFloats :: SimplFloats -> SimplFloats
    930 930
     -- If any are type bindings they must be non-recursive, so
    
    931 931
     --   do not need to be joined into a letrec; indeed they must not
    
    932 932
     --   since Rec{} is not allowed to have type binders
    
    933
    -mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff
    
    933
    +mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats val_bs ff
    
    934 934
                                     , sfJoinFloats = join_bs
    
    935 935
                                     , sfInScope    = in_scope })
    
    936
    -  = assertPpr (isNilOL bs || isNilOL join_bs) (ppr floats) $
    
    937
    -    SimplFloats { sfLetFloats  = LetFloats (type_bs `appOL` val_b) ff
    
    936
    +  = assertPpr (isNilOL val_bs || isNilOL join_bs) (ppr floats) $
    
    937
    +    SimplFloats { sfLetFloats  = LetFloats val_b ff
    
    938 938
                     , sfJoinFloats = join_b
    
    939 939
                     , sfInScope    = in_scope }
    
    940 940
       where
    
    941
    -    type_bs, val_bs :: OrdList OutBind
    
    942
    -    (type_bs, val_bs) = partitionOL isTypeBind bs
    
    943
    -
    
    944 941
         -- See Note [Bangs in the Simplifier]
    
    945 942
         !val_b  | isNilOL val_bs  = nilOL
    
    946
    -            | otherwise       = unitOL (Rec (flattenBinds (fromOL val_bs)))
    
    943
    +            | otherwise       = toOL (glomValBinds (fromOL val_bs))
    
    947 944
         !join_b | isNilOL join_bs = nilOL
    
    948
    -            | otherwise       = unitOL (Rec (flattenBinds (fromOL join_bs)))
    
    945
    +            | otherwise       = toOL (glomValBinds (fromOL join_bs))
    
    949 946
     
    
    950 947
     wrapFloats :: SimplFloats -> OutExpr -> OutExpr
    
    951 948
     -- Wrap the floats around the expression
    

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -204,6 +204,9 @@ simplTopBinds env0 binds0
    204 204
                     -- anything into scope, then we don't get a complaint about that.
    
    205 205
                     -- It's rather as if the top-level binders were imported.
    
    206 206
                     -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".
    
    207
    +                --
    
    208
    +                -- But the type of that top-level binder might mention a let-bound
    
    209
    +                -- type variable, so we put all those let-bindings at the front
    
    207 210
             -- See Note [Bangs in the Simplifier]
    
    208 211
             ; (ty_floats,  env1) <- {-#SCC "simplTopBinds-simplRecBndrs" #-}
    
    209 212
                                     simplTopTyVarBinds env0 binds0
    
    ... ... @@ -291,10 +294,12 @@ simplTyVarBind :: SimplEnv -> InTyVar -> InType
    291 294
     -- Returned SimplFloats is empty, or singleton type binding
    
    292 295
     simplTyVarBind env tv ty
    
    293 296
       | Just env' <- preInlineTypeUnconditionally env tv ty
    
    294
    -  = return (emptyFloats env', env')
    
    297
    +  = -- pprTrace "Pre-inline-tv" (ppr tv <+> equals <+> ppr ty) $
    
    298
    +    return (emptyFloats env', env')
    
    295 299
       | otherwise
    
    296 300
       = do { ty' <- simplType env ty
    
    297
    -       ; completeTyVarBindX env (zapTyVarUnfolding tv) ty' }
    
    301
    +       ; -- pprTrace "Don't pre-inline-tv" (ppr tv <+> equals <+> ppr ty') $
    
    302
    +         completeTyVarBindX env (zapTyVarUnfolding tv) ty' }
    
    298 303
              -- Zap any unfolding because competeTyVarBindX will add
    
    299 304
              -- the new unfolding and we don't wnat to waste work
    
    300 305
              -- substituting the old one
    
    ... ... @@ -303,7 +308,8 @@ completeTyVarBindX :: SimplEnv -> InTyVar -> OutType
    303 308
                        -> SimplM (SimplFloats, SimplEnv)
    
    304 309
     completeTyVarBindX env in_tv out_ty
    
    305 310
       | postInlineTypeUnconditionally out_ty
    
    306
    -  = return (emptyFloats env, extendTvSubst env in_tv out_ty)
    
    311
    +  = -- pprTrace "Post-inline-tv" (ppr in_tv <+> equals <+> ppr out_ty) $
    
    312
    +    return (emptyFloats env, extendTvSubst env in_tv out_ty)
    
    307 313
     
    
    308 314
       | otherwise
    
    309 315
       = do { (env1, out_tv) <- simplTyVarBndr env in_tv
    
    ... ... @@ -314,7 +320,9 @@ completeTyVarBindX env in_tv out_ty
    314 320
                    --     occurrence of in_tv. After all, in a beta-redex, in_tv
    
    315 321
                    --     had no unfolding. See (TCL2) in
    
    316 322
                    --     Note [Type and coercion lets] in GHC.Core
    
    317
    -       ; return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) }
    
    323
    +       ; -- pprTrace "Don't post-inline-tv" (ppr in_tv <+> equals <+> ppr out_tv_w_unf
    
    324
    +         --                                  <+> equals <+> ppr out_ty) $
    
    325
    +         return (mkFloatBind env2 (NonRec out_tv_w_unf (Type out_ty))) }
    
    318 326
     
    
    319 327
     {-
    
    320 328
     ************************************************************************
    

  • compiler/GHC/Core/Opt/Simplify/Utils.hs
    ... ... @@ -1444,7 +1444,7 @@ preInlineTypeUnconditionally env tv rhs_ty
    1444 1444
       -- Inline unconditionally if it occurs exactly once, inside a lambda or not.
    
    1445 1445
       -- No work is wasted by substituting inside a lambda, although if the
    
    1446 1446
       -- lambda is inlined a lot, we migth duplicate the type.
    
    1447
    -  | OneOcc{ occ_n_br = 1 } <- tyVarOccInfo tv
    
    1447
    +  | isOneTyCoOcc (tyVarOccInfo tv)
    
    1448 1448
       = Just $! extendTvSubst env tv $! substTy env rhs_ty
    
    1449 1449
     
    
    1450 1450
       | otherwise
    

  • compiler/GHC/Core/Opt/Specialise.hs
    ... ... @@ -780,10 +780,10 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
    780 780
                  local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
    
    781 781
                  final_binds
    
    782 782
                    | null spec_binds = wrapDictBinds dict_binds []
    
    783
    -               | otherwise       = [Rec $ mapFst (addRulesToId local_rule_base) $
    
    784
    -                                          flattenBinds                          $
    
    785
    -                                          wrapDictBinds dict_binds              $
    
    786
    -                                          spec_binds]
    
    783
    +               | otherwise       = glomValBinds $
    
    784
    +                                   wrapDictBinds dict_binds                          $
    
    785
    +                                   map (mapBindBndrs (addRulesToId local_rule_base)) $
    
    786
    +                                   spec_binds
    
    787 787
     
    
    788 788
            ; return (rules_for_imps, final_binds)
    
    789 789
         }
    

  • compiler/GHC/Core/Ppr.hs
    ... ... @@ -472,7 +472,12 @@ pprTypedLetBinder binder
    472 472
     pprKindedTyVarBndr :: TyVar -> SDoc
    
    473 473
     -- Print a type variable binder with its kind (but not if *)
    
    474 474
     pprKindedTyVarBndr tyvar
    
    475
    -  = text "@" <> pprTyVarWithKind tyvar
    
    475
    +  = text "@" <> pp_occ <> pprTyVarWithKind tyvar
    
    476
    +  where
    
    477
    +    pp_occ = case tyVarOccInfo tyvar of
    
    478
    +               TyCoDead -> text "[dead]"
    
    479
    +               TyCoOne  -> text "[one]"
    
    480
    +               TyCoMany -> empty
    
    476 481
     
    
    477 482
     -- pprId x prints x :: ty
    
    478 483
     pprId :: Id -> SDoc
    

  • compiler/GHC/Core/SimpleOpt.hs
    ... ... @@ -153,8 +153,7 @@ simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    153 153
     -- created from DynFlags, but not necessarily.
    
    154 154
     
    
    155 155
     simpleOptExpr opts expr
    
    156
    -  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
    
    157
    -    simpleOptExprWith opts init_subst expr
    
    156
    +  = simpleOptExprWith opts init_subst expr
    
    158 157
       where
    
    159 158
         init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr)))
    
    160 159
             -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr]
    
    ... ... @@ -176,9 +175,10 @@ simpleOptExprNoInline opts expr
    176 175
     simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
    
    177 176
     -- See Note [The simple optimiser]
    
    178 177
     simpleOptExprWith opts subst expr
    
    179
    -  = simple_opt_expr init_env (occurAnalyseExpr expr)
    
    178
    +  = simple_opt_expr init_env occ_expr
    
    180 179
       where
    
    181 180
         init_env = (emptyEnv opts) { soe_subst = subst }
    
    181
    +    occ_expr = occurAnalyseExpr expr
    
    182 182
     
    
    183 183
     ----------------------
    
    184 184
     simpleOptPgm :: SimpleOpts
    
    ... ... @@ -493,7 +493,7 @@ simple_type_bind env@(SOE { soe_subst = subst })
    493 493
       | occurs_once || typeIsSmallEnoughToInline out_ty
    
    494 494
       = (env { soe_subst = extendTvSubst subst in_tv out_ty }, Nothing)
    
    495 495
     
    
    496
    -  | otherwise
    
    496
    +  | otherwise  -- Make a type binding
    
    497 497
       = let (subst1, tv1) = substTyVarBndr subst in_tv
    
    498 498
             out_tv = tv1 `setTyVarUnfolding` out_ty
    
    499 499
         in ( env { soe_subst = extendTvSubst subst1 in_tv (mkTyVarTy out_tv) }
    
    ... ... @@ -504,7 +504,7 @@ simple_type_bind env@(SOE { soe_subst = subst })
    504 504
         subst_for_rhs = setInScope (soe_subst rhs_env) (substInScopeSet subst)
    
    505 505
         out_ty        = substTyUnchecked subst_for_rhs in_ty
    
    506 506
         bndr_occ      = tyVarOccInfo in_tv
    
    507
    -    occurs_once {- syntactically -} = isOneOcc bndr_occ && occ_n_br bndr_occ == 1
    
    507
    +    occurs_once {- syntactically -} = isOneTyCoOcc bndr_occ
    
    508 508
     
    
    509 509
     ----------------------
    
    510 510
     simple_bind_pair :: SimpleOptEnv
    
    ... ... @@ -1621,7 +1621,7 @@ exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)
    1621 1621
         | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e
    
    1622 1622
         -- Only do value lambdas.
    
    1623 1623
         -- this implies that x is not in scope in gamma (makes this code simpler)
    
    1624
    -    , not (isTyVar x) && not (isCoVar x)
    
    1624
    +    , isNonCoVarId x
    
    1625 1625
         , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True
    
    1626 1626
         , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co
    
    1627 1627
         , let res = Just (x',e',ts)
    

  • compiler/GHC/Types/Basic.hs
    ... ... @@ -73,6 +73,8 @@ module GHC.Types.Basic (
    73 73
             isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
    
    74 74
             isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
    
    75 75
     
    
    76
    +        TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc,
    
    77
    +
    
    76 78
             InsideLam(..),
    
    77 79
             BranchCount, oneBranch,
    
    78 80
             InterestingCxt(..),
    
    ... ... @@ -1380,8 +1382,25 @@ point can also be invoked from other join points, not just from case branches:
    1380 1382
     
    
    1381 1383
     Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
    
    1382 1384
     ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`.
    
    1385
    +-}
    
    1383 1386
     
    
    1384
    -************************************************************************
    
    1387
    +data TyCoOccInfo = TyCoDead | TyCoOne | TyCoMany
    
    1388
    +
    
    1389
    +instance Outputable TyCoOccInfo where
    
    1390
    +   ppr TyCoDead = text "dead"
    
    1391
    +   ppr TyCoOne  = text "one"
    
    1392
    +   ppr TyCoMany = text "many"
    
    1393
    +
    
    1394
    +isOneTyCoOcc :: TyCoOccInfo -> Bool
    
    1395
    +isOneTyCoOcc TyCoOne = True
    
    1396
    +isOneTyCoOcc _       = False
    
    1397
    +
    
    1398
    +plusTyCoOccInfo :: TyCoOccInfo -> TyCoOccInfo -> TyCoOccInfo
    
    1399
    +plusTyCoOccInfo TyCoDead occ = occ
    
    1400
    +plusTyCoOccInfo occ TyCoDead = occ
    
    1401
    +plusTyCoOccInfo _ _        = TyCoMany
    
    1402
    +
    
    1403
    +{-**********************************************************************
    
    1385 1404
     *                                                                      *
    
    1386 1405
                     Default method specification
    
    1387 1406
     *                                                                      *
    
    ... ... @@ -2461,4 +2480,4 @@ convImportLevel NotLevelled = NormalLevel
    2461 2480
     
    
    2462 2481
     convImportLevelSpec :: ImportDeclLevel -> ImportLevel
    
    2463 2482
     convImportLevelSpec ImportDeclQuote = QuoteLevel
    
    2464
    -convImportLevelSpec ImportDeclSplice = SpliceLevel
    \ No newline at end of file
    2483
    +convImportLevelSpec ImportDeclSplice = SpliceLevel

  • compiler/GHC/Types/Var.hs
    ... ... @@ -128,7 +128,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy )
    128 128
     import GHC.Types.Name hiding (varName)
    
    129 129
     import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique
    
    130 130
                             , nonDetCmpUnique )
    
    131
    -import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo )
    
    131
    +import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo, TyCoOccInfo(..) )
    
    132 132
     import GHC.Utils.Misc
    
    133 133
     import GHC.Utils.Binary
    
    134 134
     import GHC.Utils.Outputable
    
    ... ... @@ -269,7 +269,7 @@ data Var
    269 269
             varType      :: Kind,          -- ^ The type or kind of the 'Var' in question
    
    270 270
             tv_unfolding :: Maybe Type,    -- ^ The type to which the variable is bound to,
    
    271 271
                                            -- if any, see Note [Type and coercion lets] in GHC.Core
    
    272
    -        tv_occ_info  :: OccInfo
    
    272
    +        tv_occ_info  :: TyCoOccInfo
    
    273 273
      }
    
    274 274
     
    
    275 275
       | TcTyVar {                           -- Used only during type inference
    
    ... ... @@ -1032,8 +1032,8 @@ tyVarUnfolding_maybe :: TyVar -> Maybe Type
    1032 1032
     tyVarUnfolding_maybe (TyVar { tv_unfolding = unf }) = unf
    
    1033 1033
     tyVarUnfolding_maybe _ = Nothing
    
    1034 1034
     
    
    1035
    -tyVarOccInfo :: TyVar -> OccInfo
    
    1036
    -tyVarOccInfo (TcTyVar {}) = noOccInfo
    
    1035
    +tyVarOccInfo :: TyVar -> TyCoOccInfo
    
    1036
    +tyVarOccInfo (TcTyVar {}) = TyCoMany
    
    1037 1037
     tyVarOccInfo tv = assertPpr (isTyVar tv) (ppr tv) $ tv_occ_info tv
    
    1038 1038
     
    
    1039 1039
     setTyVarUnique :: TyVar -> Unique -> TyVar
    
    ... ... @@ -1059,7 +1059,7 @@ zapTyVarUnfolding tv@(TcTyVar {}) = tv
    1059 1059
       -- Why: because zapTyVarUnfolding is called by substTyBndr during typechecking
    
    1060 1060
     zapTyVarUnfolding v = pprPanic "zapTyVarUnfolding" (ppr v)
    
    1061 1061
     
    
    1062
    -setTyVarOccInfo :: HasDebugCallStack => TyVar -> OccInfo -> TyVar
    
    1062
    +setTyVarOccInfo :: HasDebugCallStack => TyVar -> TyCoOccInfo -> TyVar
    
    1063 1063
     setTyVarOccInfo tv@(TyVar {}) occ_info
    
    1064 1064
       = tv {tv_occ_info = occ_info}
    
    1065 1065
     setTyVarOccInfo tv            occ_info
    
    ... ... @@ -1101,7 +1101,7 @@ mkTyVar name kind = TyVar { varName = name
    1101 1101
                               , realUnique   = nameUnique name
    
    1102 1102
                               , varType      = kind
    
    1103 1103
                               , tv_unfolding = Nothing
    
    1104
    -                          , tv_occ_info  = noOccInfo
    
    1104
    +                          , tv_occ_info  = TyCoMany
    
    1105 1105
                               }
    
    1106 1106
     
    
    1107 1107
     mkTyVarWithUnfolding :: Name -> Kind -> Type -> TyVar
    
    ... ... @@ -1109,7 +1109,7 @@ mkTyVarWithUnfolding name kind unf = TyVar { varName = name
    1109 1109
                                                , realUnique   = nameUnique name
    
    1110 1110
                                                , varType      = kind
    
    1111 1111
                                                , tv_unfolding = Just unf
    
    1112
    -                                           , tv_occ_info  = noOccInfo
    
    1112
    +                                           , tv_occ_info  = TyCoMany
    
    1113 1113
                                                }
    
    1114 1114
     
    
    1115 1115
     mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar