| ... |
... |
@@ -57,7 +57,7 @@ import GHC.Types.Var ( isTyCoVar ) |
|
57
|
57
|
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
|
|
58
|
58
|
import GHC.Builtin.Names( runRWKey, seqHashKey )
|
|
59
|
59
|
|
|
60
|
|
-import GHC.Data.Maybe ( isNothing, orElse, mapMaybe )
|
|
|
60
|
+import GHC.Data.Maybe ( isJust, orElse, mapMaybe )
|
|
61
|
61
|
import GHC.Data.FastString
|
|
62
|
62
|
import GHC.Unit.Module ( moduleName )
|
|
63
|
63
|
import GHC.Utils.Outputable
|
| ... |
... |
@@ -2121,7 +2121,7 @@ wrapJoinCont env cont thing_inside |
|
2121
|
2121
|
trimJoinCont :: Id -- Used only in error message
|
|
2122
|
2122
|
-> JoinPointHood
|
|
2123
|
2123
|
-> SimplCont -> SimplCont
|
|
2124
|
|
--- Drop outer context from join point invocation (jump)
|
|
|
2124
|
+-- Discard outer context from join point invocation (jump)
|
|
2125
|
2125
|
-- See Note [Join points and case-of-case]
|
|
2126
|
2126
|
|
|
2127
|
2127
|
trimJoinCont _ NotJoinPoint cont
|
| ... |
... |
@@ -2165,7 +2165,9 @@ evaluation context E): |
|
2165
|
2165
|
As is evident from the example, there are two components to this behavior:
|
|
2166
|
2166
|
|
|
2167
|
2167
|
1. When entering the RHS of a join point, copy the context inside.
|
|
|
2168
|
+
|
|
2168
|
2169
|
2. When a join point is invoked, discard the outer context.
|
|
|
2170
|
+ See `trimJoinCont`
|
|
2169
|
2171
|
|
|
2170
|
2172
|
We need to be very careful here to remain consistent---neither part is
|
|
2171
|
2173
|
optional!
|
| ... |
... |
@@ -3909,13 +3911,49 @@ mkDupableContWithDmds env _ |
|
3909
|
3911
|
; mkDupableStrictBind env bndr' join_body res_ty }
|
|
3910
|
3912
|
|
|
3911
|
3913
|
mkDupableContWithDmds env _
|
|
3912
|
|
- (StrictArg { sc_fun = fun, sc_cont = cont
|
|
3913
|
|
- , sc_fun_ty = fun_ty })
|
|
|
3914
|
+ (StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty })
|
|
|
3915
|
+ -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
|
|
|
3916
|
+ | isJust (isDataConId_maybe (ai_fun fun))
|
|
|
3917
|
+ -- isDataConId: see point (DJ4) of Note [Duplicating join points]
|
|
|
3918
|
+ = -- Use Plan B of Note [Duplicating StrictArg]
|
|
|
3919
|
+ -- K[ f a b <> ] --> join j x = K[ f a b x ]
|
|
|
3920
|
+ -- j <>
|
|
|
3921
|
+ do { let rhs_ty = contResultType cont
|
|
|
3922
|
+ (m,arg_ty,_) = splitFunTy fun_ty
|
|
|
3923
|
+ ; arg_bndr <- newId (fsLit "arg") m arg_ty
|
|
|
3924
|
+ ; let env' = env `addNewInScopeIds` [arg_bndr]
|
|
|
3925
|
+ ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
|
|
|
3926
|
+ ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
|
|
|
3927
|
+
|
|
|
3928
|
+ | otherwise
|
|
|
3929
|
+ = -- Use Plan C of Note [Duplicating StrictArg]
|
|
|
3930
|
+ -- K[ f a b <> ] --> join j x = K[ x ]
|
|
|
3931
|
+ -- K1[ f a b <> ]
|
|
|
3932
|
+ -- where K1 = j <>
|
|
|
3933
|
+ do { let rhs_ty = contResultType cont
|
|
|
3934
|
+ (m,_,res_ty) = splitFunTy fun_ty
|
|
|
3935
|
+ ; (floats, cont') <-
|
|
|
3936
|
+ if contIsTrivial cont
|
|
|
3937
|
+ then return (emptyFloats env, cont)
|
|
|
3938
|
+ else do { arg_bndr <- newId (fsLit "arg") m res_ty
|
|
|
3939
|
+ ; let env' = env `addNewInScopeIds` [arg_bndr]
|
|
|
3940
|
+ ; rhs' <- simplExprC env' (Var arg_bndr) cont
|
|
|
3941
|
+ ; mkDupableStrictBind env' arg_bndr rhs' rhs_ty }
|
|
|
3942
|
+
|
|
|
3943
|
+ ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) (ai_args fun)
|
|
|
3944
|
+
|
|
|
3945
|
+ ; return ( foldl' addLetFloats floats floats_s
|
|
|
3946
|
+ , StrictArg { sc_fun = fun { ai_args = args' }
|
|
|
3947
|
+ , sc_cont = cont', sc_dup = OkToDup, sc_fun_ty = fun_ty }) }
|
|
|
3948
|
+
|
|
|
3949
|
+{-
|
|
3914
|
3950
|
-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
|
|
3915
|
3951
|
| isNothing (isDataConId_maybe (ai_fun fun))
|
|
3916
|
3952
|
-- isDataConId: see point (DJ4) of Note [Duplicating join points]
|
|
3917
|
3953
|
, thumbsUpPlanA cont
|
|
3918
|
3954
|
= -- Use Plan A of Note [Duplicating StrictArg]
|
|
|
3955
|
+ -- K[ f a b <> ] --> let xa = a; xb = b
|
|
|
3956
|
+ -- K[ f xa xb <> ]
|
|
3919
|
3957
|
-- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $
|
|
3920
|
3958
|
do { let _ :| dmds = expectNonEmpty $ ai_dmds fun
|
|
3921
|
3959
|
; (floats1, cont') <- mkDupableContWithDmds env dmds cont
|
| ... |
... |
@@ -3951,6 +3989,7 @@ mkDupableContWithDmds env _ |
|
3951
|
3989
|
thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k
|
|
3952
|
3990
|
thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k
|
|
3953
|
3991
|
-}
|
|
|
3992
|
+-}
|
|
3954
|
3993
|
|
|
3955
|
3994
|
mkDupableContWithDmds env dmds
|
|
3956
|
3995
|
(ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
|
| ... |
... |
@@ -4037,7 +4076,10 @@ mkDupableContWithDmds env _ |
|
4037
|
4076
|
|
|
4038
|
4077
|
mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
|
|
4039
|
4078
|
-> SimplM (SimplFloats, SimplCont)
|
|
4040
|
|
-mkDupableStrictBind env arg_bndr join_rhs res_ty
|
|
|
4079
|
+-- mkDupableStrictBind env arg body rhs_ty
|
|
|
4080
|
+-- generates join-floats join j arg = body
|
|
|
4081
|
+-- cont StrictArg (jump j <>) : Stop
|
|
|
4082
|
+mkDupableStrictBind env arg_bndr join_rhs join_rhs_ty
|
|
4041
|
4083
|
| uncondInlineJoin [arg_bndr] join_rhs
|
|
4042
|
4084
|
-- See point (DJ2) of Note [Duplicating join points]
|
|
4043
|
4085
|
= return (emptyFloats env
|
| ... |
... |
@@ -4047,9 +4089,9 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty |
|
4047
|
4089
|
, sc_from = FromLet
|
|
4048
|
4090
|
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
|
|
4049
|
4091
|
, sc_dup = OkToDup
|
|
4050
|
|
- , sc_cont = mkBoringStop res_ty } )
|
|
|
4092
|
+ , sc_cont = mkBoringStop join_rhs_ty } )
|
|
4051
|
4093
|
| otherwise
|
|
4052
|
|
- = do { join_bndr <- newJoinId [arg_bndr] res_ty
|
|
|
4094
|
+ = do { join_bndr <- newJoinId [arg_bndr] join_rhs_ty
|
|
4053
|
4095
|
; let arg_info = ArgInfo { ai_fun = join_bndr
|
|
4054
|
4096
|
, ai_rules = [], ai_args = []
|
|
4055
|
4097
|
, ai_encl = False, ai_dmds = repeat topDmd
|
| ... |
... |
@@ -4061,7 +4103,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty |
|
4061
|
4103
|
, StrictArg { sc_dup = OkToDup
|
|
4062
|
4104
|
, sc_fun = arg_info
|
|
4063
|
4105
|
, sc_fun_ty = idType join_bndr
|
|
4064
|
|
- , sc_cont = mkBoringStop res_ty
|
|
|
4106
|
+ , sc_cont = mkBoringStop join_rhs_ty
|
|
4065
|
4107
|
} ) }
|
|
4066
|
4108
|
|
|
4067
|
4109
|
mkDupableAlt :: SimplEnv -> OutId
|