+
+
+specCase :: Subst
+ -> CoreExpr -- Scrutinee, already done
+ -> Id -> [CoreAlt]
+ -> SpecM ( CoreExpr -- New scrutinee
+ , Id
+ , [CoreAlt]
+ , UsageDetails)
+specCase subst scrut' case_bndr [(con, args, rhs)]
+ | isDictId case_bndr -- See Note [Floating dictionaries out of cases]
+ , interestingDict scrut'
+ , not (isDeadBinder case_bndr && null sc_args')
+ = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
+
+ ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
+ [(con, args', Var sc_arg')]
+ | sc_arg' <- sc_args' ]
+
+ -- Extend the substitution for RHS to map the *original* binders
+ -- to their floated verions. Attach an unfolding to these floated
+ -- binders so they look interesting to interestingDict
+ mb_sc_flts :: [Maybe DictId]
+ mb_sc_flts = map (lookupVarEnv clone_env) args'
+ clone_env = zipVarEnv sc_args' (zipWith add_unf sc_args_flt sc_rhss)
+ subst_prs = (case_bndr, Var (add_unf case_bndr_flt scrut'))
+ : [ (arg, Var sc_flt)
+ | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
+ subst_rhs' = extendIdSubstList subst_rhs subst_prs
+
+ ; (rhs', rhs_uds) <- specExpr subst_rhs' rhs
+ ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut')
+ case_bndr_set = unitVarSet case_bndr_flt
+ sc_binds = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
+ | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
+ flt_binds = scrut_bind : sc_binds
+ (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
+ all_uds = flt_binds `addDictBinds` free_uds
+ alt' = (con, args', wrapDictBindsE dumped_dbs rhs')
+ ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
+ where
+ (subst_rhs, (case_bndr':args')) = substBndrs subst (case_bndr:args)
+ sc_args' = filter is_flt_sc_arg args'
+
+ clone_me bndr = do { uniq <- getUniqueM
+ ; return (mkUserLocal occ uniq ty loc) }
+ where
+ name = idName bndr
+ ty = idType bndr
+ occ = nameOccName name
+ loc = getSrcSpan name
+
+ add_unf sc_flt sc_rhs -- Sole purpose: make sc_flt respond True to interestingDictId
+ = setIdUnfolding sc_flt (mkSimpleUnfolding sc_rhs)
+
+ arg_set = mkVarSet args'
+ is_flt_sc_arg var = isId var
+ && not (isDeadBinder var)
+ && isDictTy var_ty
+ && not (tyVarsOfType var_ty `intersectsVarSet` arg_set)
+ where
+ var_ty = idType var
+
+
+specCase subst scrut case_bndr alts
+ = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
+ ; return (scrut, case_bndr', alts', uds_alts) }
+ where
+ (subst_alt, case_bndr') = substBndr subst case_bndr
+ spec_alt (con, args, rhs) = do
+ (rhs', uds) <- specExpr subst_rhs rhs
+ let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
+ return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
+ where
+ (subst_rhs, args') = substBndrs subst_alt args