diff options
Diffstat (limited to 'compiler/GHC/Core/SimpleOpt.hs')
| -rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 42 |
1 files changed, 35 insertions, 7 deletions
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 609d007a5a..77ddde68a2 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1219,11 +1219,8 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } - = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) - float = FloatCase arg' bndr DEFAULT [] - subst' = subst_extend_in_scope subst bndr - in go subst' (float:floats) fun (CC (Var bndr : args) co) + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) co) | otherwise = go subst floats fun (CC (subst_expr subst arg : args) co) @@ -1262,8 +1259,9 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args co + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' co -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do @@ -1349,6 +1347,36 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + mkFieldSeqFloats in_scope dc args + | Nothing <- dataConRepStrictness_maybe dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual "mkFieldSeqFloats" str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = (in_scope, floats, arg:args) + | Var v <- arg, is_evald v = (in_scope, floats, arg:args) + | otherwise = (in_scope', float:floats, Var bndr:args) + where + is_evald v = isId v && isEvaldUnfolding (idUnfolding v) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) -- See Note [exprIsConApp_maybe on literal strings] dealWithStringLiteral :: Var -> BS.ByteString -> Coercion |