-simplCaseBinder :: SimplEnv -> OutExpr -> InId -> SimplM (SimplEnv, OutId)
-simplCaseBinder env scrut case_bndr
- | switchIsOn (getSwitchChecker env) NoCaseOfCase
- -- See Note [no-case-of-case]
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
-
-simplCaseBinder env (Var v) case_bndr
--- Failed try [see Note 2 above]
--- not (isEvaldUnfolding (idUnfolding v))
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; return (modifyInScope env v case_bndr', case_bndr') }
- -- We could extend the substitution instead, but it would be
- -- a hack because then the substitution wouldn't be idempotent
- -- any more (v is an OutId). And this does just as well.
-
-simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast]
- = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
- ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
- ; return (addBinderUnfolding env v rhs, case_bndr') }
-
-simplCaseBinder env other_scrut case_bndr
- = do { (env, case_bndr') <- simplBinder env case_bndr
- ; return (env, case_bndr') }
+simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt]
+ -> SimplM (SimplEnv, OutExpr, OutId)
+simplCaseBinder env scrut case_bndr alts
+ = do { (env1, case_bndr1) <- simplBinder env case_bndr
+
+ ; fam_envs <- getFamEnvs
+ ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut
+ case_bndr case_bndr1 alts
+ -- Note [Improving seq]
+
+ ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2
+ -- Note [Case of cast]
+
+ ; return (env3, scrut2, case_bndr3) }
+ where
+
+ improve_seq fam_envs env1 scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
+ | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
+ = do { case_bndr2 <- newId FSLIT("nt") ty2
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+ env2 = extendIdSubst env1 case_bndr rhs
+ ; return (env2, scrut `Cast` co, case_bndr2) }
+
+ improve_seq fam_envs env1 scrut case_bndr case_bndr1 alts
+ = return (env1, scrut, case_bndr1)
+
+
+ improve_case_bndr env scrut case_bndr
+ | switchIsOn (getSwitchChecker env) NoCaseOfCase
+ -- See Note [no-case-of-case]
+ = (env, case_bndr)
+
+ | otherwise -- Failed try [see Note 2 above]
+ -- not (isEvaldUnfolding (idUnfolding v))
+ = case scrut of
+ Var v -> (modifyInScope env1 v case_bndr', case_bndr')
+ -- Note about using modifyInScope for v here
+ -- We could extend the substitution instead, but it would be
+ -- a hack because then the substitution wouldn't be idempotent
+ -- any more (v is an OutId). And this does just as well.
+
+ Cast (Var v) co -> (addBinderUnfolding env1 v rhs, case_bndr')
+ where
+ rhs = Cast (Var case_bndr') (mkSymCoercion co)
+
+ other -> (env, case_bndr)
+ where
+ case_bndr' = zapOccInfo case_bndr
+ env1 = modifyInScope env case_bndr case_bndr'
+
projects / ghc-hetmet.git / commitdiff