- ----------------------------
- -- pin default FVs on first!
- --
- get_fvs_from_deflt_and_alts (AnnAlgAlts alts deflt)
- = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, _, rhs) <- alts ]
-
- get_fvs_from_deflt_and_alts (AnnPrimAlts alts deflt)
- = get_deflt_fvs deflt : [ freeVarsOf rhs | (_, rhs) <- alts]
-
- get_deflt_fvs AnnNoDefault = emptyIdSet
- get_deflt_fvs (AnnBindDefault b rhs) = freeVarsOf rhs
-
- ----------------------------
- fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
- = AlgAlts
- [ (con, params, fiExpr to_drop rhs)
- | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
- (fi_default to_drop_deflt deflt)
-
- fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
- = PrimAlts
- [ (lit, fiExpr to_drop rhs)
- | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
- (fi_default to_drop_deflt deflt)
-
- fi_default to_drop AnnNoDefault = NoDefault
- fi_default to_drop (AnnBindDefault b e) = BindDefault b (fiExpr to_drop e)
+ -- Float into the scrut and alts-considered-together just like App
+ [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
+
+ -- Float into the alts with the is_case flag set
+ (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
+
+ scrut_fvs = freeVarsOf scrut
+ alts_fvs = map alt_fvs alts
+ all_alts_fvs = unionVarSets alts_fvs
+ alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args)
+ -- Delete case_bndr and args from free vars of rhs
+ -- to get free vars of alt
+
+ fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs)
+
+noFloatIntoRhs (AnnNote InlineMe _) = True
+noFloatIntoRhs (AnnLam b _) = not (isId b && isOneShotLambda b)
+ -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top.
+ -- This makes a big difference for things like
+ -- f x# = let x = I# x#
+ -- in let j = \() -> ...x...
+ -- in if <condition> then normal-path else j ()
+ -- If x is used only in the error case join point, j, we must float the
+ -- boxing constructor into it, else we box it every time which is very bad
+ -- news indeed.
+
+noFloatIntoRhs rhs = exprIsValue (deAnnotate' rhs) -- We'd just float rigt back out again...