- -- Sigh: rather disgusting case for coercions. We want to
- -- ensure that all let-bound Coerces have atomic bodies, so
- -- they can freely be inlined.
-completeNonRec env binder@(_,occ_info) (Coerce coercion ty rhs)
- = (case rhs of
- Var v -> returnSmpl (env, [], rhs)
- Lit l -> returnSmpl (env, [], rhs)
- other -> newId (coreExprType rhs) `thenSmpl` \ inner_id ->
- completeNonRec env
- (inner_id, dangerousArgOcc) rhs `thenSmpl` \ (env1, extra_bind) ->
- -- Dangerous occ because, like constructor args,
- -- it can be duplicated easily
- let
- atomic_rhs = case lookupId env1 inner_id of
- LitArg l -> Lit l
- VarArg v -> Var v
- in
- returnSmpl (env1, extra_bind, atomic_rhs)
- ) `thenSmpl` \ (env1, extra_bind, atomic_rhs) ->
- -- Tiresome to do all this, but we must treat the lit/var cases specially
- -- or we get a tick for atomic rhs when effectively it's a no-op.
-
- cloneId env1 binder `thenSmpl` \ new_id ->
- let
- new_rhs = Coerce coercion ty atomic_rhs
- env2 = extendIdEnvWithClone env1 binder new_id
- new_env = extendEnvGivenBinding env2 occ_info new_id new_rhs
- in
- returnSmpl (new_env, extra_bind ++ [NonRec new_id new_rhs])
-
-completeNonRec env binder new_rhs
- -- See if RHS is an atom, or a reusable constructor
- | maybeToBool maybe_atomic_rhs
- = let
- new_env = extendIdEnvWithAtom env binder rhs_atom
- in
- tick atom_tick_type `thenSmpl_`
- returnSmpl (new_env, [])
- where
- maybe_atomic_rhs = exprToAtom env new_rhs
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
-completeNonRec env binder@(_,occ_info) new_rhs
- = cloneId env binder `thenSmpl` \ new_id ->
+ -- We want to ensure that all let-bound Coerces have
+ -- atomic bodies, so they can freely be inlined.
+completeNonRec env binder new_id (Coerce coercion ty rhs)
+ | not (is_atomic rhs)
+ = newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+ completeNonRec env
+ (inner_id, dangerousArgOcc) inner_id rhs `thenSmpl` \ (env1, binds1) ->
+ -- Dangerous occ because, like constructor args,
+ -- it can be duplicated easily