1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Pierre Chambart, OCamlPro *) 6(* Mark Shinwell and Leo White, Jane Street Europe *) 7(* *) 8(* Copyright 2013--2016 OCamlPro SAS *) 9(* Copyright 2014--2016 Jane Street Group LLC *) 10(* *) 11(* All rights reserved. This file is distributed under the terms of *) 12(* the GNU Lesser General Public License version 2.1, with the *) 13(* special exception on linking described in the file LICENSE. *) 14(* *) 15(**************************************************************************) 16 17[@@@ocaml.warning "+a-4-9-30-40-41-42"] 18 19let apply_on_subexpressions f f_named (flam : Flambda.t) = 20 match flam with 21 | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable 22 | Static_raise _ -> () 23 | Let { defining_expr; body; _ } -> 24 f_named defining_expr; 25 f body 26 | Let_mutable { body; _ } -> 27 f body 28 | Let_rec (defs, body) -> 29 List.iter (fun (_,l) -> f_named l) defs; 30 f body 31 | Switch (_, sw) -> 32 List.iter (fun (_,l) -> f l) sw.consts; 33 List.iter (fun (_,l) -> f l) sw.blocks; 34 Misc.may f sw.failaction 35 | String_switch (_, sw, def) -> 36 List.iter (fun (_,l) -> f l) sw; 37 Misc.may f def 38 | Static_catch (_,_,f1,f2) -> 39 f f1; f f2; 40 | Try_with (f1,_,f2) -> 41 f f1; f f2 42 | If_then_else (_,f1, f2) -> 43 f f1;f f2 44 | While (f1,f2) -> 45 f f1; f f2 46 | For { body; _ } -> f body 47 48let rec list_map_sharing f l = 49 match l with 50 | [] -> l 51 | h :: t -> 52 let new_t = list_map_sharing f t in 53 let new_h = f h in 54 if h == new_h && t == new_t then 55 l 56 else 57 new_h :: new_t 58 59let may_map_sharing f v = 60 match v with 61 | None -> v 62 | Some s -> 63 let new_s = f s in 64 if s == new_s then 65 v 66 else 67 Some new_s 68 69let map_snd_sharing f ((a, b) as cpl) = 70 let new_b = f a b in 71 if b == new_b then 72 cpl 73 else 74 (a, new_b) 75 76let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t = 77 match tree with 78 | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable 79 | Static_raise _ -> tree 80 | Let { var; defining_expr; body; _ } -> 81 let new_named = f_named var defining_expr in 82 let new_body = f body in 83 if new_named == defining_expr && new_body == body then 84 tree 85 else 86 Flambda.create_let var new_named new_body 87 | Let_rec (defs, body) -> 88 let new_defs = 89 list_map_sharing (map_snd_sharing f_named) defs 90 in 91 let new_body = f body in 92 if new_defs == defs && new_body == body then 93 tree 94 else 95 Let_rec (new_defs, new_body) 96 | Let_mutable mutable_let -> 97 let new_body = f mutable_let.body in 98 if new_body == mutable_let.body then 99 tree 100 else 101 Let_mutable { mutable_let with body = new_body } 102 | Switch (arg, sw) -> 103 let aux = map_snd_sharing (fun _ v -> f v) in 104 let new_consts = list_map_sharing aux sw.consts in 105 let new_blocks = list_map_sharing aux sw.blocks in 106 let new_failaction = may_map_sharing f sw.failaction in 107 if sw.failaction == new_failaction && 108 new_consts == sw.consts && 109 new_blocks == sw.blocks then 110 tree 111 else 112 let sw = 113 { sw with 114 failaction = new_failaction; 115 consts = new_consts; 116 blocks = new_blocks; 117 } 118 in 119 Switch (arg, sw) 120 | String_switch (arg, sw, def) -> 121 let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in 122 let new_def = may_map_sharing f def in 123 if sw == new_sw && def == new_def then 124 tree 125 else 126 String_switch(arg, new_sw, new_def) 127 | Static_catch (i, vars, body, handler) -> 128 let new_body = f body in 129 let new_handler = f handler in 130 if new_body == body && new_handler == handler then 131 tree 132 else 133 Static_catch (i, vars, new_body, new_handler) 134 | Try_with(body, id, handler) -> 135 let new_body = f body in 136 let new_handler = f handler in 137 if body == new_body && handler == new_handler then 138 tree 139 else 140 Try_with(new_body, id, new_handler) 141 | If_then_else(arg, ifso, ifnot) -> 142 let new_ifso = f ifso in 143 let new_ifnot = f ifnot in 144 if new_ifso == ifso && new_ifnot == ifnot then 145 tree 146 else 147 If_then_else(arg, new_ifso, new_ifnot) 148 | While(cond, body) -> 149 let new_cond = f cond in 150 let new_body = f body in 151 if new_cond == cond && new_body == body then 152 tree 153 else 154 While(new_cond, new_body) 155 | For { bound_var; from_value; to_value; direction; body; } -> 156 let new_body = f body in 157 if new_body == body then 158 tree 159 else 160 For { bound_var; from_value; to_value; direction; body = new_body; } 161 162let iter_general = Flambda.iter_general 163 164let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t) 165let iter_expr f t = iter f (fun _ -> ()) t 166let iter_on_named f f_named t = 167 iter_general ~toplevel:false f f_named (Is_named t) 168let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t 169let iter_named_on_named f_named named = 170 iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named 171 (Is_named named) 172 173let iter_toplevel f f_named t = 174 iter_general ~toplevel:true f f_named (Is_expr t) 175let iter_named_toplevel f f_named named = 176 iter_general ~toplevel:true f f_named (Is_named named) 177 178let iter_all_immutable_let_and_let_rec_bindings t ~f = 179 iter_expr (function 180 | Let { var; defining_expr; _ } -> f var defining_expr 181 | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs 182 | _ -> ()) 183 t 184 185let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f = 186 iter_general ~toplevel:true 187 (function 188 | Let { var; defining_expr; _ } -> f var defining_expr 189 | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs 190 | _ -> ()) 191 (fun _ -> ()) 192 (Is_expr t) 193 194let iter_on_sets_of_closures f t = 195 iter_named (function 196 | Set_of_closures clos -> f clos 197 | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ 198 | Read_symbol_field _ 199 | Project_closure _ | Move_within_set_of_closures _ | Project_var _ 200 | Prim _ | Expr _ -> ()) 201 t 202 203let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f = 204 let rec loop (program : Flambda.program_body) = 205 match program with 206 | Let_symbol (_, Set_of_closures set_of_closures, program) -> 207 Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> 208 f function_decl.body) 209 set_of_closures.function_decls.funs; 210 loop program 211 | Let_rec_symbol (defs, program) -> 212 List.iter (function 213 | (_, Flambda.Set_of_closures set_of_closures) -> 214 Variable.Map.iter 215 (fun _ (function_decl : Flambda.function_declaration) -> 216 f function_decl.body) 217 set_of_closures.function_decls.funs 218 | _ -> ()) defs; 219 loop program 220 | Let_symbol (_, _, program) -> 221 loop program 222 | Initialize_symbol (_, _, fields, program) -> 223 List.iter f fields; 224 loop program 225 | Effect (expr, program) -> 226 f expr; 227 loop program 228 | End _ -> () 229 in 230 loop program.program_body 231 232let iter_named_of_program program ~f = 233 iter_exprs_at_toplevel_of_program program ~f:(iter_named f) 234 235let iter_on_set_of_closures_of_program (program : Flambda.program) ~f = 236 let rec loop (program : Flambda.program_body) = 237 match program with 238 | Let_symbol (_, Set_of_closures set_of_closures, program) -> 239 f ~constant:true set_of_closures; 240 Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) -> 241 iter_on_sets_of_closures (f ~constant:false) function_decl.body) 242 set_of_closures.function_decls.funs; 243 loop program 244 | Let_rec_symbol (defs, program) -> 245 List.iter (function 246 | (_, Flambda.Set_of_closures set_of_closures) -> 247 f ~constant:true set_of_closures; 248 Variable.Map.iter 249 (fun _ (function_decl : Flambda.function_declaration) -> 250 iter_on_sets_of_closures (f ~constant:false) function_decl.body) 251 set_of_closures.function_decls.funs 252 | _ -> ()) defs; 253 loop program 254 | Let_symbol (_, _, program) -> 255 loop program 256 | Initialize_symbol (_, _, fields, program) -> 257 List.iter (iter_on_sets_of_closures (f ~constant:false)) fields; 258 loop program 259 | Effect (expr, program) -> 260 iter_on_sets_of_closures (f ~constant:false) expr; 261 loop program 262 | End _ -> () 263 in 264 loop program.program_body 265 266let iter_constant_defining_values_on_program (program : Flambda.program) ~f = 267 let rec loop (program : Flambda.program_body) = 268 match program with 269 | Let_symbol (_, const, program) -> 270 f const; 271 loop program 272 | Let_rec_symbol (defs, program) -> 273 List.iter (fun (_, const) -> f const) defs; 274 loop program 275 | Initialize_symbol (_, _, _, program) -> 276 loop program 277 | Effect (_, program) -> 278 loop program 279 | End _ -> () 280 in 281 loop program.program_body 282 283let map_general ~toplevel f f_named tree = 284 let rec aux (tree : Flambda.t) = 285 match tree with 286 | Let _ -> 287 Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux 288 ~after_rebuild:f 289 | _ -> 290 let exp : Flambda.t = 291 match tree with 292 | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable 293 | Static_raise _ -> tree 294 | Let _ -> assert false 295 | Let_mutable mutable_let -> 296 let new_body = aux mutable_let.body in 297 if new_body == mutable_let.body then 298 tree 299 else 300 Let_mutable { mutable_let with body = new_body } 301 | Let_rec (defs, body) -> 302 let done_something = ref false in 303 let defs = 304 List.map (fun (id, lam) -> 305 id, aux_named_done_something id lam done_something) 306 defs 307 in 308 let body = aux_done_something body done_something in 309 if not !done_something then 310 tree 311 else 312 Let_rec (defs, body) 313 | Switch (arg, sw) -> 314 let done_something = ref false in 315 let sw = 316 { sw with 317 failaction = 318 begin match sw.failaction with 319 | None -> None 320 | Some failaction -> 321 Some (aux_done_something failaction done_something) 322 end; 323 consts = 324 List.map (fun (i, v) -> 325 i, aux_done_something v done_something) 326 sw.consts; 327 blocks = 328 List.map (fun (i, v) -> 329 i, aux_done_something v done_something) 330 sw.blocks; 331 } 332 in 333 if not !done_something then 334 tree 335 else 336 Switch (arg, sw) 337 | String_switch (arg, sw, def) -> 338 let done_something = ref false in 339 let sw = 340 List.map (fun (i, v) -> i, aux_done_something v done_something) sw 341 in 342 let def = 343 match def with 344 | None -> None 345 | Some def -> Some (aux_done_something def done_something) 346 in 347 if not !done_something then 348 tree 349 else 350 String_switch(arg, sw, def) 351 | Static_catch (i, vars, body, handler) -> 352 let new_body = aux body in 353 let new_handler = aux handler in 354 if new_body == body && new_handler == handler then 355 tree 356 else 357 Static_catch (i, vars, new_body, new_handler) 358 | Try_with(body, id, handler) -> 359 let new_body = aux body in 360 let new_handler = aux handler in 361 if new_body == body && new_handler == handler then 362 tree 363 else 364 Try_with (new_body, id, new_handler) 365 | If_then_else (arg, ifso, ifnot) -> 366 let new_ifso = aux ifso in 367 let new_ifnot = aux ifnot in 368 if new_ifso == ifso && new_ifnot == ifnot then 369 tree 370 else 371 If_then_else (arg, new_ifso, new_ifnot) 372 | While (cond, body) -> 373 let new_cond = aux cond in 374 let new_body = aux body in 375 if new_cond == cond && new_body == body then 376 tree 377 else 378 While (new_cond, new_body) 379 | For { bound_var; from_value; to_value; direction; body; } -> 380 let new_body = aux body in 381 if new_body == body then 382 tree 383 else 384 For { bound_var; from_value; to_value; direction; 385 body = new_body; } 386 in 387 f exp 388 and aux_done_something expr done_something = 389 let new_expr = aux expr in 390 if not (new_expr == expr) then begin 391 done_something := true 392 end; 393 new_expr 394 and aux_named (id : Variable.t) (named : Flambda.named) = 395 let named : Flambda.named = 396 match named with 397 | Symbol _ | Const _ | Allocated_const _ | Read_mutable _ 398 | Project_closure _ | Move_within_set_of_closures _ | Project_var _ 399 | Prim _ | Read_symbol_field _ -> named 400 | Set_of_closures ({ function_decls; free_vars; specialised_args; 401 direct_call_surrogates }) -> 402 if toplevel then named 403 else begin 404 let done_something = ref false in 405 let funs = 406 Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> 407 let new_body = aux func_decl.body in 408 if new_body == func_decl.body then begin 409 func_decl 410 end else begin 411 done_something := true; 412 Flambda.create_function_declaration 413 ~params:func_decl.params 414 ~body:new_body 415 ~stub:func_decl.stub 416 ~dbg:func_decl.dbg 417 ~inline:func_decl.inline 418 ~specialise:func_decl.specialise 419 ~is_a_functor:func_decl.is_a_functor 420 end) 421 function_decls.funs 422 in 423 if not !done_something then 424 named 425 else 426 let function_decls = 427 Flambda.update_function_declarations function_decls ~funs 428 in 429 let set_of_closures = 430 Flambda.create_set_of_closures ~function_decls ~free_vars 431 ~specialised_args ~direct_call_surrogates 432 in 433 Set_of_closures set_of_closures 434 end 435 | Expr expr -> 436 let new_expr = aux expr in 437 if new_expr == expr then named 438 else Expr new_expr 439 in 440 f_named id named 441 and aux_named_done_something id named done_something = 442 let new_named = aux_named id named in 443 if not (new_named == named) then begin 444 done_something := true 445 end; 446 new_named 447 in 448 aux tree 449 450let iter_apply_on_program program ~f = 451 iter_exprs_at_toplevel_of_program program ~f:(fun expr -> 452 iter (function 453 | Apply apply -> f apply 454 | _ -> ()) 455 (fun _ -> ()) 456 expr) 457 458let map f f_named tree = 459 map_general ~toplevel:false f (fun _ n -> f_named n) tree 460let map_expr f tree = map f (fun named -> named) tree 461let map_named f_named tree = map (fun expr -> expr) f_named tree 462let map_named_with_id f_named tree = 463 map_general ~toplevel:false (fun expr -> expr) f_named tree 464let map_toplevel f f_named tree = 465 map_general ~toplevel:true f (fun _ n -> f_named n) tree 466let map_toplevel_expr f_expr tree = 467 map_toplevel f_expr (fun named -> named) tree 468let map_toplevel_named f_named tree = 469 map_toplevel (fun tree -> tree) f_named tree 470 471let map_symbols tree ~f = 472 map_named (function 473 | (Symbol sym) as named -> 474 let new_sym = f sym in 475 if new_sym == sym then 476 named 477 else 478 Symbol new_sym 479 | ((Read_symbol_field (sym, field)) as named) -> 480 let new_sym = f sym in 481 if new_sym == sym then 482 named 483 else 484 Read_symbol_field (new_sym, field) 485 | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _ 486 | Project_closure _ | Move_within_set_of_closures _ | Project_var _ 487 | Prim _ | Expr _) as named -> named) 488 tree 489 490let map_symbols_on_set_of_closures 491 ({ Flambda.function_decls; free_vars; specialised_args; 492 direct_call_surrogates; } as 493 set_of_closures) 494 ~f = 495 let done_something = ref false in 496 let funs = 497 Variable.Map.map (fun (func_decl : Flambda.function_declaration) -> 498 let body = map_symbols func_decl.body ~f in 499 if not (body == func_decl.body) then begin 500 done_something := true; 501 end; 502 Flambda.create_function_declaration 503 ~params:func_decl.params 504 ~body 505 ~stub:func_decl.stub 506 ~dbg:func_decl.dbg 507 ~inline:func_decl.inline 508 ~specialise:func_decl.specialise 509 ~is_a_functor:func_decl.is_a_functor) 510 function_decls.funs 511 in 512 if not !done_something then 513 set_of_closures 514 else 515 let function_decls = 516 Flambda.update_function_declarations function_decls ~funs 517 in 518 Flambda.create_set_of_closures ~function_decls ~free_vars 519 ~specialised_args ~direct_call_surrogates 520 521let map_toplevel_sets_of_closures tree ~f = 522 map_toplevel_named (function 523 | (Set_of_closures set_of_closures) as named -> 524 let new_set_of_closures = f set_of_closures in 525 if new_set_of_closures == set_of_closures then 526 named 527 else 528 Set_of_closures new_set_of_closures 529 | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _ 530 | Read_symbol_field _ 531 | Project_closure _ | Move_within_set_of_closures _ | Project_var _ 532 | Prim _ | Expr _) as named -> named) 533 tree 534 535let map_apply tree ~f = 536 map (function 537 | (Apply apply) as expr -> 538 let new_apply = f apply in 539 if new_apply == apply then 540 expr 541 else 542 Apply new_apply 543 | expr -> expr) 544 (fun named -> named) 545 tree 546 547let map_sets_of_closures tree ~f = 548 map_named (function 549 | (Set_of_closures set_of_closures) as named -> 550 let new_set_of_closures = f set_of_closures in 551 if new_set_of_closures == set_of_closures then 552 named 553 else 554 Set_of_closures new_set_of_closures 555 | (Symbol _ | Const _ | Allocated_const _ | Project_closure _ 556 | Move_within_set_of_closures _ | Project_var _ 557 | Prim _ | Expr _ | Read_mutable _ 558 | Read_symbol_field _) as named -> named) 559 tree 560 561let map_project_var_to_expr_opt tree ~f = 562 map_named (function 563 | (Project_var project_var) as named -> 564 begin match f project_var with 565 | None -> named 566 | Some expr -> Expr expr 567 end 568 | (Symbol _ | Const _ | Allocated_const _ 569 | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ 570 | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) 571 as named -> named) 572 tree 573 574let map_project_var_to_named_opt tree ~f = 575 map_named (function 576 | (Project_var project_var) as named -> 577 begin match f project_var with 578 | None -> named 579 | Some named -> named 580 end 581 | (Symbol _ | Const _ | Allocated_const _ 582 | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ 583 | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _) 584 as named -> named) 585 tree 586 587let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f = 588 let done_something = ref false in 589 let funs = 590 Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> 591 let new_body = f function_decl.body in 592 if new_body == function_decl.body then 593 function_decl 594 else begin 595 done_something := true; 596 Flambda.create_function_declaration ~body:new_body 597 ~params:function_decl.params 598 ~stub:function_decl.stub 599 ~dbg:function_decl.dbg 600 ~inline:function_decl.inline 601 ~specialise:function_decl.specialise 602 ~is_a_functor:function_decl.is_a_functor 603 end) 604 set_of_closures.function_decls.funs 605 in 606 if not !done_something then 607 set_of_closures 608 else 609 let function_decls = 610 Flambda.update_function_declarations set_of_closures.function_decls ~funs 611 in 612 Flambda.create_set_of_closures 613 ~function_decls 614 ~free_vars:set_of_closures.free_vars 615 ~specialised_args:set_of_closures.specialised_args 616 ~direct_call_surrogates:set_of_closures.direct_call_surrogates 617 618let map_sets_of_closures_of_program (program : Flambda.program) 619 ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) = 620 let rec loop (program : Flambda.program_body) : Flambda.program_body = 621 let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = 622 let done_something = ref false in 623 let function_decls = 624 let funs = 625 Variable.Map.map (fun 626 (function_decl : Flambda.function_declaration) -> 627 let body = map_sets_of_closures ~f function_decl.body in 628 if body == function_decl.body then 629 function_decl 630 else begin 631 done_something := true; 632 Flambda.create_function_declaration ~body 633 ~params:function_decl.params 634 ~stub:function_decl.stub 635 ~dbg:function_decl.dbg 636 ~inline:function_decl.inline 637 ~specialise:function_decl.specialise 638 ~is_a_functor:function_decl.is_a_functor 639 end) 640 set_of_closures.function_decls.funs 641 in 642 if not !done_something then 643 set_of_closures.function_decls 644 else 645 Flambda.update_function_declarations set_of_closures.function_decls 646 ~funs 647 in 648 let new_set_of_closures = f set_of_closures in 649 if new_set_of_closures == set_of_closures then 650 set_of_closures 651 else 652 Flambda.create_set_of_closures ~function_decls 653 ~free_vars:set_of_closures.free_vars 654 ~specialised_args:set_of_closures.specialised_args 655 ~direct_call_surrogates:set_of_closures.direct_call_surrogates 656 in 657 match program with 658 | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> 659 let new_set_of_closures = map_constant_set_of_closures set_of_closures in 660 let new_program' = loop program' in 661 if new_set_of_closures == set_of_closures 662 && new_program' == program' then 663 program 664 else 665 Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') 666 | Let_symbol (symbol, const, program') -> 667 let new_program' = loop program' in 668 if new_program' == program' then 669 program 670 else 671 Let_symbol (symbol, const, new_program') 672 | Let_rec_symbol (defs, program') -> 673 let done_something = ref false in 674 let defs = 675 List.map (function 676 | (var, Flambda.Set_of_closures set_of_closures) -> 677 let new_set_of_closures = 678 map_constant_set_of_closures set_of_closures 679 in 680 if not (new_set_of_closures == set_of_closures) then begin 681 done_something := true 682 end; 683 var, Flambda.Set_of_closures new_set_of_closures 684 | def -> def) 685 defs 686 in 687 let new_program' = loop program' in 688 if new_program' == program' && not !done_something then 689 program 690 else 691 Let_rec_symbol (defs, loop program') 692 | Initialize_symbol (symbol, tag, fields, program') -> 693 let done_something = ref false in 694 let fields = 695 List.map (fun field -> 696 let new_field = map_sets_of_closures field ~f in 697 if not (new_field == field) then begin 698 done_something := true 699 end; 700 new_field) 701 fields 702 in 703 let new_program' = loop program' in 704 if new_program' == program' && not !done_something then 705 program 706 else 707 Initialize_symbol (symbol, tag, fields, new_program') 708 | Effect (expr, program') -> 709 let new_expr = map_sets_of_closures expr ~f in 710 let new_program' = loop program' in 711 if new_expr == expr && new_program' == program' then 712 program 713 else 714 Effect (new_expr, new_program') 715 | End _ -> program 716 in 717 { program with 718 program_body = loop program.program_body; 719 } 720 721let map_exprs_at_toplevel_of_program (program : Flambda.program) 722 ~(f : Flambda.t -> Flambda.t) = 723 let rec loop (program : Flambda.program_body) : Flambda.program_body = 724 let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) = 725 let done_something = ref false in 726 let funs = 727 Variable.Map.map (fun (function_decl : Flambda.function_declaration) -> 728 let body = f function_decl.body in 729 if body == function_decl.body then 730 function_decl 731 else begin 732 done_something := true; 733 Flambda.create_function_declaration ~body 734 ~params:function_decl.params 735 ~stub:function_decl.stub 736 ~dbg:function_decl.dbg 737 ~inline:function_decl.inline 738 ~specialise:function_decl.specialise 739 ~is_a_functor:function_decl.is_a_functor 740 end) 741 set_of_closures.function_decls.funs 742 in 743 if not !done_something then 744 set_of_closures 745 else 746 let function_decls = 747 Flambda.update_function_declarations set_of_closures.function_decls 748 ~funs 749 in 750 Flambda.create_set_of_closures ~function_decls 751 ~free_vars:set_of_closures.free_vars 752 ~specialised_args:set_of_closures.specialised_args 753 ~direct_call_surrogates:set_of_closures.direct_call_surrogates 754 in 755 (* CR-soon mshinwell: code very similar to the above function *) 756 match program with 757 | Let_symbol (symbol, Set_of_closures set_of_closures, program') -> 758 let new_set_of_closures = map_constant_set_of_closures set_of_closures in 759 let new_program' = loop program' in 760 if new_set_of_closures == set_of_closures 761 && new_program' == program' then 762 program 763 else 764 Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program') 765 | Let_symbol (symbol, const, program') -> 766 let new_program' = loop program' in 767 if new_program' == program' then 768 program 769 else 770 Let_symbol (symbol, const, new_program') 771 | Let_rec_symbol (defs, program') -> 772 let done_something = ref false in 773 let defs = 774 List.map (function 775 | (var, Flambda.Set_of_closures set_of_closures) -> 776 let new_set_of_closures = 777 map_constant_set_of_closures set_of_closures 778 in 779 if not (new_set_of_closures == set_of_closures) then begin 780 done_something := true 781 end; 782 var, Flambda.Set_of_closures new_set_of_closures 783 | def -> def) 784 defs 785 in 786 let new_program' = loop program' in 787 if new_program' == program' && not !done_something then 788 program 789 else 790 Let_rec_symbol (defs, new_program') 791 | Initialize_symbol (symbol, tag, fields, program') -> 792 let done_something = ref false in 793 let fields = 794 List.map (fun field -> 795 let new_field = f field in 796 if not (new_field == field) then begin 797 done_something := true 798 end; 799 new_field) 800 fields 801 in 802 let new_program' = loop program' in 803 if new_program' == program' && not !done_something then 804 program 805 else 806 Initialize_symbol (symbol, tag, fields, new_program') 807 | Effect (expr, program') -> 808 let new_expr = f expr in 809 let new_program' = loop program' in 810 if new_expr == expr && new_program' == program' then 811 program 812 else 813 Effect (new_expr, new_program') 814 | End _ -> program 815 in 816 { program with 817 program_body = loop program.program_body; 818 } 819 820let map_named_of_program (program : Flambda.program) 821 ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program = 822 map_exprs_at_toplevel_of_program program 823 ~f:(fun expr -> map_named_with_id f expr) 824 825let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t) 826 ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t = 827 map_named_with_id f expr 828 829let fold_function_decls_ignoring_stubs 830 (set_of_closures : Flambda.set_of_closures) ~init ~f = 831 Variable.Map.fold (fun fun_var function_decl acc -> 832 f ~fun_var ~function_decl acc) 833 set_of_closures.function_decls.funs 834 init 835