diff options
Diffstat (limited to 'ghc/compiler/stranal/WwLib.lhs')
| -rw-r--r-- | ghc/compiler/stranal/WwLib.lhs | 21 |
1 files changed, 14 insertions, 7 deletions
diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index e1a1da6463..b84f9c60b3 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -429,8 +429,9 @@ mkWWcpr body_ty RetCPR arg = mk_ww_local arg_uniq con_arg_ty1 con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]) in - returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)], - \ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)], +-- gaw 2004 + returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)], + \ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)], con_arg_ty1) | otherwise -- The general case @@ -445,8 +446,9 @@ mkWWcpr body_ty RetCPR ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) in - returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)], - \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)], +-- gaw 2004 + returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)], + \ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)], ubx_tup_ty) where (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty @@ -467,8 +469,10 @@ mkWWcpr body_ty other -- No CPR info -- This transform doesn't move work or allocation -- from one cost centre to another -workerCase (Note (SCC cc) e) arg alts = Note (SCC cc) (Case e arg alts) -workerCase e arg alts = Case e arg alts +-- gaw 2004 +workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts) +-- gaw 2004 +workerCase e arg ty alts = Case e arg ty alts \end{code} @@ -494,9 +498,12 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body -- A data type = Case (Var arg) (sanitiseCaseBndr arg) +-- gaw 2004 + (exprType body) [(DataAlt boxing_con, unpk_args, body)] -mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)] +-- gaw 2004 +mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] sanitiseCaseBndr :: Id -> Id -- The argument we are scrutinising has the right type to be |