+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
+ = let
+ env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
+ env2_ids = varSetElems env2_id_set
+ env2_ty = tupleType env2_ids
+ in
+
+ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+ getUniqSupplyDs `thenDs` \ uniqs ->
+ newSysLocalDs env2_ty `thenDs` \ env2_id ->
+ let
+ later_ty = tupleType later_ids
+ post_pair_ty = mkCoreTupTy [later_ty, env2_ty]
+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
+ in
+ matchEnvStack later_ids [env2_id] post_loop_body
+ `thenDs` \ post_loop_fn ->
+
+ --- loop (...)
+
+ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+ `thenDs` \ (core_loop, env1_id_set, env1_ids) ->
+
+ -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+ let
+ env1_ty = tupleType env1_ids
+ pre_pair_ty = mkCoreTupTy [env1_ty, env2_ty]
+ pre_loop_body = mkCoreTup [mkTupleExpr env1_ids, mkTupleExpr env2_ids]
+
+ in
+ matchEnvStack env_ids [] pre_loop_body
+ `thenDs` \ pre_loop_fn ->
+
+ -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+ let
+ env_ty = tupleType env_ids
+ out_ty = tupleType out_ids
+ core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
+ pre_loop_fn
+ (do_compose ids pre_pair_ty post_pair_ty out_ty
+ (do_first ids env1_ty later_ty env2_ty
+ core_loop)
+ (do_arr ids post_pair_ty out_ty
+ post_loop_fn))
+ in
+ returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
+-- ss >>>
+-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
+
+dsRecCmd ids local_vars stmts later_ids rec_ids rhss