- ------------ Floating stuff -------------------
-
- float_lets = switchIsSet env SimplFloatLetsExposingWHNF
- always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
-
- float (binder,rhs)
- = let
- pairs_s = float_pair (binder,rhs)
- in
- case pairs_s of
- [_] -> returnSmpl pairs_s
- more_than_one
- -> tickN LetFloatFromLet (length pairs_s - 1) `thenSmpl_`
- -- It's important to increment the tick counts if we
- -- do any floating. A situation where this turns out
- -- to be important is this:
- -- Float in produces:
- -- letrec x = let y = Ey in Ex
- -- in B
- -- Now floating gives this:
- -- letrec x = Ex
- -- y = Ey
- -- in B
- --- We now want to iterate once more in case Ey doesn't
- -- mention x, in which case the y binding can be pulled
- -- out as an enclosing let(rec), which in turn gives
- -- the strictness analyser more chance.
- returnSmpl pairs_s
-
- float_pairs pairs = concat (map float_pair pairs)
-
- float_pair (binder, rhs)
- | always_float_let_from_let ||
- floatExposesHNF True False False rhs
- = (binder,rhs') : pairs'
-
- | otherwise
- = [(binder,rhs)]
- where
- (pairs', rhs') = do_float rhs
-
- -- Float just pulls out any top-level let(rec) bindings
- do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
- do_float (Let (Rec pairs) body) = (float_pairs pairs ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
- where
- (pairs', body') = do_float body
- do_float other = ([], other)
-
-simplRecursiveGroup env triples
- = -- Toss out all the dead pairs? No, there shouldn't be any!
- -- Dead code is discarded by the occurrence analyser
- let
- -- Separate the live triples into "inline"able and
- -- "ordinary" We're paranoid about duplication!
- (inline_triples, ordinary_triples)
- = partition is_inline_triple triples
-
- is_inline_triple (_, ((_,occ_info),_))
- = inlineUnconditionally False {-not ok_to_dup-} occ_info
-
- -- Now add in the inline_pairs info (using "env_w_clones"),
- -- so that we will save away suitably-clone-laden envs
- -- inside the InlineIts...).
-
- -- NOTE ALSO that we tie a knot here, because the
- -- saved-away envs must also include these very inlinings
- -- (they aren't stored anywhere else, and a late one might
- -- be used in an early one).
-
- env_w_inlinings = foldl add_inline env inline_triples
-
- add_inline env (id', (binder,rhs))
- = extendIdEnvWithInlining env env_w_inlinings binder rhs
-
- -- Separate the remaining bindings into the ones which
- -- need to be dealt with first (the "early" ones)
- -- and the others (the "late" ones)
- (early_triples, late_triples)
- = partition is_early_triple ordinary_triples
-
- is_early_triple (_, (_, Con _ _ _)) = True
- is_early_triple (i, _ ) = idWantsToBeINLINEd i
- in
- -- Process the early bindings first
- mapSmpl (do_one_binding env_w_inlinings) early_triples `thenSmpl` \ early_triples' ->
-
- -- Now further extend the environment to record our knowledge
- -- about the form of the binders bound in the constructor bindings
- let
- env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
- add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
- in
- -- Now process the non-constructor bindings
- mapSmpl (do_one_binding env_w_early_info) late_triples `thenSmpl` \ late_triples' ->
-
- -- Phew! We're done
- let
- binding = Rec (map snd early_triples' ++ map snd late_triples')
- in
- returnSmpl (binding, env_w_early_info)
+ Just (rhs_arg, tick_type) = maybe_atomic_rhs
+ maybe_atomic_rhs
+ = -- Try first for an existing constructor application
+ case maybe_con new_rhs of {
+ Just con -> Just (VarArg con, ConReused);
+
+ Nothing -> -- No good; try eta-reduction
+ case etaCoreExpr new_rhs of {
+ Var v -> Just (VarArg v, AtomicRhs);
+ Lit l -> Just (LitArg l, AtomicRhs);
+
+ other -> Nothing -- Neither worked, so return Nothing
+ }}
+
+
+ maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
+ = lookForConstructor env con con_args
+ maybe_con other_rhs = Nothing
+
+completeNonRec env binder@(id,occ_info) new_id new_rhs
+ = returnSmpl (new_env , [NonRec new_id new_rhs])