- 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')) ->
+ sc_con_app con args scrut' -- Known constructor; simplify
+ = do { let (_, bs, rhs) = findAlt con alts
+ alt_env' = extendScSubst 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')
+ <- mapAndUnzip3Us (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, bs') = extendBndrsWith RecArg env bs
+ env2 = extendCaseBndrs env1 scrut' b' con bs'
+ ; (usg,rhs') <- scExpr env2 rhs
+ ; let (usg', arg_occs) = lookupOccs usg bs
+ scrut_occ = case con of
+ DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
+ other -> ScrutOcc emptyUFM
+ ; return (usg', scrut_occ, (con,bs',rhs')) }
+
+scExpr' env (Let (NonRec bndr rhs) body)
+ = do { let (body_env, bndr') = extendBndr env bndr
+ ; (rhs_usg, rhs_info@(_, args', rhs_body', _)) <- scRecRhs env (bndr',rhs)
+
+ ; if null args' || isEmptyVarEnv (calls rhs_usg) then do
+ do { -- Vanilla case
+ let rhs' = mkLams args' rhs_body'
+ body_env2 = extendValEnv body_env bndr' (isValue (sc_vals env) rhs')
+ -- Record if the RHS is a value
+ ; (body_usg, body') <- scExpr body_env2 body
+ ; return (body_usg `combineUsage` rhs_usg, Let (NonRec bndr' rhs') body') }
+ else
+ do { -- Join-point case
+ let body_env2 = extendHowBound body_env [bndr'] RecFun
+ -- If the RHS of this 'let' contains calls
+ -- to recursive functions that we're trying
+ -- to specialise, then treat this let too
+ -- as one to specialise
+ ; (body_usg, body') <- scExpr body_env2 body
+
+ ; (spec_usg, _, specs) <- specialise env (calls body_usg) ([], rhs_info)
+
+ ; return (body_usg { calls = calls body_usg `delVarEnv` bndr' }
+ `combineUsage` rhs_usg `combineUsage` spec_usg,
+ mkLets [NonRec b r | (b,r) <- addRules rhs_info specs] body')
+ } }
+
+scExpr' env (Let (Rec prs) body)
+ = do { (env', bind_usg, bind') <- scBind env (Rec prs)
+ ; (body_usg, body') <- scExpr env' body
+ ; return (bind_usg `combineUsage` body_usg, Let bind' body') }
+
+scExpr' env e@(App _ _)
+ = do { let (fn, args) = collectArgs e
+ ; (fn_usg, fn') <- scExpr env fn
projects / ghc-hetmet.git / blobdiff