- sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e)
- sc_scrut e = scExpr env e
-
- sc_alt (con,bs,rhs) = scExpr env1 rhs `thenUs` \ (usg,rhs') ->
- returnUs (usg, (con,bs,rhs'))
- where
- env1 = extendCaseBndrs env b scrut con bs
-
-scExpr env (Let bind body)
- = scBind env bind `thenUs` \ (env', bind_usg, bind') ->
- scExpr env' body `thenUs` \ (body_usg, body') ->
- returnUs (bind_usg `combineUsage` body_usg, Let bind' body')
-
-scExpr env e@(App _ _)
- = let
- (fn, args) = collectArgs e
- in
- mapAndUnzipUs (scExpr env) (fn:args) `thenUs` \ (usgs, (fn':args')) ->
- -- Process the function too. It's almost always a variable,
- -- but not always. In particular, if this pass follows float-in,
- -- which it may, we can get
- -- (let f = ...f... in f) arg1 arg2
- let
- call_usg = case fn of
- Var f | Just RecFun <- lookupScopeEnv env f
- -> SCU { calls = unitVarEnv f [(cons env, args)],
- occs = emptyVarEnv }
- other -> nullUsage
- in
- returnUs (combineUsages usgs `combineUsage` call_usg, mkApps fn' args')
+ sc_con_app con args scrut' -- Known constructor; simplify
+ = do { let (_, bs, rhs) = findAlt con alts
+ `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+ alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+ ; scExpr alt_env' rhs }
+
+ sc_vanilla scrut_usg scrut' -- Normal case
+ = do { let (alt_env,b') = extendBndrWith RecArg env b
+ -- Record RecArg for the components
+
+ ; (alt_usgs, alt_occs, alts')
+ <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
+
+ ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b'
+ scrut_occ = foldr combineOcc b_occ alt_occs
+ scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
+ -- The combined usage of the scrutinee is given
+ -- by scrut_occ, which is passed to scScrut, which
+ -- in turn treats a bare-variable scrutinee specially
+
+ ; return (alt_usg `combineUsage` scrut_usg',
+ Case scrut' b' (scSubstTy env ty) alts') }
+
+ sc_alt env _scrut' b' (con,bs,rhs)
+ = do { let (env1, bs1) = extendBndrsWith RecArg env bs
+ (env2, bs2) = extendCaseBndrs env1 b' con bs1
+ ; (usg,rhs') <- scExpr env2 rhs
+ ; let (usg', arg_occs) = lookupOccs usg bs2
+ scrut_occ = case con of
+ DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
+ _ -> ScrutOcc emptyUFM
+ ; return (usg', scrut_occ, (con, bs2, rhs')) }
+
+scExpr' env (Let (NonRec bndr rhs) body)
+ | isTyVar bndr -- Type-lets may be created by doBeta
+ = scExpr' (extendScSubst env bndr rhs) body
+
+ | otherwise -- Note [Local let bindings]
+ = do { let (body_env, bndr') = extendBndr env bndr
+ body_env2 = extendHowBound body_env [bndr'] RecFun
+ ; (body_usg, body') <- scExpr body_env2 body
+
+ ; (rhs_usg, rhs_info) <- scRecRhs env (bndr',rhs)
+
+ -- NB: We don't use the ForceSpecConstr mechanism (see
+ -- Note [Forcing specialisation]) for non-recursive bindings
+ -- at the moment. I'm not sure if this is the right thing to do.
+ ; let force_spec = False
+ ; (spec_usg, specs) <- specialise env force_spec
+ (scu_calls body_usg)
+ rhs_info
+ (SI [] 0 (Just rhs_usg))
+
+ ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+ `combineUsage` spec_usg,
+ mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
+ }
+
+
+-- A *local* recursive group: see Note [Local recursive groups]
+scExpr' env (Let (Rec prs) body)
+ = do { let (bndrs,rhss) = unzip prs
+ (rhs_env1,bndrs') = extendRecBndrs env bndrs
+ rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
+ force_spec = any (forceSpecBndr env) bndrs'
+ -- Note [Forcing specialisation]
+
+ ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+ ; (body_usg, body') <- scExpr rhs_env2 body
+
+ -- NB: start specLoop from body_usg
+ ; (spec_usg, specs) <- specLoop rhs_env2 force_spec
+ (scu_calls body_usg) rhs_infos nullUsage
+ [SI [] 0 (Just usg) | usg <- rhs_usgs]
+ -- Do not unconditionally use rhs_usgs.
+ -- Instead use them only if we find an unspecialised call
+ -- See Note [Local recursive groups]
+
+ ; let all_usg = spec_usg `combineUsage` body_usg
+ bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
+
+ ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+ Let bind' body') }
+\end{code}