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-30-40-41-42"] 18 19type flambda_kind = 20 | Normal 21 | Lifted 22 23(* Explicit "ignore" functions. We name every pattern variable, avoiding 24 underscores, to try to avoid accidentally failing to handle (for example) 25 a particular variable. 26 We also avoid explicit record field access during the checking functions, 27 preferring instead to use exhaustive record matches. 28*) 29(* CR-someday pchambart: for sum types, we should probably add an exhaustive 30 pattern in ignores functions to be reminded if a type change *) 31let already_added_bound_variable_to_env (_ : Variable.t) = () 32let will_traverse_named_expression_later (_ : Flambda.named) = () 33let ignore_variable (_ : Variable.t) = () 34let ignore_call_kind (_ : Flambda.call_kind) = () 35let ignore_debuginfo (_ : Debuginfo.t) = () 36let ignore_meth_kind (_ : Lambda.meth_kind) = () 37let ignore_int (_ : int) = () 38let ignore_int_set (_ : Numbers.Int.Set.t) = () 39let ignore_bool (_ : bool) = () 40let ignore_string (_ : string) = () 41let ignore_static_exception (_ : Static_exception.t) = () 42let ignore_direction_flag (_ : Asttypes.direction_flag) = () 43let ignore_primitive ( _ : Lambda.primitive) = () 44let ignore_const (_ : Flambda.const) = () 45let ignore_allocated_const (_ : Allocated_const.t) = () 46let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = () 47let ignore_set_of_closures_origin (_ : Set_of_closures_origin.t) = () 48let ignore_closure_id (_ : Closure_id.t) = () 49let ignore_var_within_closure (_ : Var_within_closure.t) = () 50let ignore_tag (_ : Tag.t) = () 51let ignore_inline_attribute (_ : Lambda.inline_attribute) = () 52let ignore_specialise_attribute (_ : Lambda.specialise_attribute) = () 53let ignore_value_kind (_ : Lambda.value_kind) = () 54 55exception Binding_occurrence_not_from_current_compilation_unit of Variable.t 56exception Mutable_binding_occurrence_not_from_current_compilation_unit of 57 Mutable_variable.t 58exception Binding_occurrence_of_variable_already_bound of Variable.t 59exception Binding_occurrence_of_mutable_variable_already_bound of 60 Mutable_variable.t 61exception Binding_occurrence_of_symbol_already_bound of Symbol.t 62exception Unbound_variable of Variable.t 63exception Unbound_mutable_variable of Mutable_variable.t 64exception Unbound_symbol of Symbol.t 65exception Vars_in_function_body_not_bound_by_closure_or_params of 66 Variable.Set.t * Flambda.set_of_closures * Variable.t 67exception Function_decls_have_overlapping_parameters of Variable.Set.t 68exception Specialised_arg_that_is_not_a_parameter of Variable.t 69exception Projection_must_be_a_free_var of Projection.t 70exception Projection_must_be_a_specialised_arg of Projection.t 71exception Free_variables_set_is_lying of 72 Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration 73exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t 74exception Static_exception_not_caught of Static_exception.t 75exception Static_exception_caught_in_multiple_places of Static_exception.t 76exception Access_to_global_module_identifier of Lambda.primitive 77exception Pidentity_should_not_occur 78exception Pdirapply_should_be_expanded 79exception Prevapply_should_be_expanded 80exception Ploc_should_be_expanded 81exception Sequential_logical_operator_primitives_must_be_expanded of 82 Lambda.primitive 83exception Var_within_closure_bound_multiple_times of Var_within_closure.t 84exception Declared_closure_from_another_unit of Compilation_unit.t 85exception Closure_id_is_bound_multiple_times of Closure_id.t 86exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t 87exception Unbound_closure_ids of Closure_id.Set.t 88exception Unbound_vars_within_closures of Var_within_closure.Set.t 89exception Move_to_a_closure_not_in_the_free_variables 90 of Variable.t * Variable.Set.t 91 92exception Flambda_invariants_failed 93 94(* CR-someday mshinwell: We should make "direct applications should not have 95 overapplication" be an invariant throughout. At the moment I think this is 96 only true after [Inline_and_simplify] has split overapplications. *) 97 98(* CR-someday mshinwell: What about checks for shadowed variables and 99 symbols? *) 100 101let variable_and_symbol_invariants (program : Flambda.program) = 102 let all_declared_variables = ref Variable.Set.empty in 103 let declare_variable var = 104 if Variable.Set.mem var !all_declared_variables then 105 raise (Binding_occurrence_of_variable_already_bound var); 106 all_declared_variables := Variable.Set.add var !all_declared_variables 107 in 108 let declare_variables vars = 109 Variable.Set.iter declare_variable vars 110 in 111 let all_declared_mutable_variables = ref Mutable_variable.Set.empty in 112 let declare_mutable_variable mut_var = 113 if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then 114 raise (Binding_occurrence_of_mutable_variable_already_bound mut_var); 115 all_declared_mutable_variables := 116 Mutable_variable.Set.add mut_var !all_declared_mutable_variables 117 in 118 let add_binding_occurrence (var_env, mut_var_env, sym_env) var = 119 let compilation_unit = Compilation_unit.get_current_exn () in 120 if not (Variable.in_compilation_unit var compilation_unit) then 121 raise (Binding_occurrence_not_from_current_compilation_unit var); 122 declare_variable var; 123 Variable.Set.add var var_env, mut_var_env, sym_env 124 in 125 let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var = 126 let compilation_unit = Compilation_unit.get_current_exn () in 127 if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then 128 raise (Mutable_binding_occurrence_not_from_current_compilation_unit 129 mut_var); 130 declare_mutable_variable mut_var; 131 var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env 132 in 133 let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym = 134 if Symbol.Set.mem sym sym_env then 135 raise (Binding_occurrence_of_symbol_already_bound sym) 136 else 137 var_env, mut_var_env, Symbol.Set.add sym sym_env 138 in 139 let add_binding_occurrences env vars = 140 List.fold_left (fun env var -> add_binding_occurrence env var) env vars 141 in 142 let check_variable_is_bound (var_env, _, _) var = 143 if not (Variable.Set.mem var var_env) then raise (Unbound_variable var) 144 in 145 let check_symbol_is_bound (_, _, sym_env) sym = 146 if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym) 147 in 148 let check_variables_are_bound env vars = 149 List.iter (check_variable_is_bound env) vars 150 in 151 let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var = 152 if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin 153 raise (Unbound_mutable_variable mut_var) 154 end 155 in 156 let rec loop env (flam : Flambda.t) = 157 match flam with 158 (* Expressions that can bind [Variable.t]s: *) 159 | Let { var; defining_expr; body; _ } -> 160 loop_named env defining_expr; 161 loop (add_binding_occurrence env var) body 162 | Let_mutable { var = mut_var; initial_value = var; 163 body; contents_kind } -> 164 ignore_value_kind contents_kind; 165 check_variable_is_bound env var; 166 loop (add_mutable_binding_occurrence env mut_var) body 167 | Let_rec (defs, body) -> 168 let env = 169 List.fold_left (fun env (var, def) -> 170 will_traverse_named_expression_later def; 171 add_binding_occurrence env var) 172 env defs 173 in 174 List.iter (fun (var, def) -> 175 already_added_bound_variable_to_env var; 176 loop_named env def) defs; 177 loop env body 178 | For { bound_var; from_value; to_value; direction; body; } -> 179 ignore_direction_flag direction; 180 check_variable_is_bound env from_value; 181 check_variable_is_bound env to_value; 182 loop (add_binding_occurrence env bound_var) body 183 | Static_catch (static_exn, vars, body, handler) -> 184 ignore_static_exception static_exn; 185 loop env body; 186 loop (add_binding_occurrences env vars) handler 187 | Try_with (body, var, handler) -> 188 loop env body; 189 loop (add_binding_occurrence env var) handler 190 (* Everything else: *) 191 | Var var -> check_variable_is_bound env var 192 | Apply { func; args; kind; dbg; inline; specialise; } -> 193 check_variable_is_bound env func; 194 check_variables_are_bound env args; 195 ignore_call_kind kind; 196 ignore_debuginfo dbg; 197 ignore_inline_attribute inline; 198 ignore_specialise_attribute specialise 199 | Assign { being_assigned; new_value; } -> 200 check_mutable_variable_is_bound env being_assigned; 201 check_variable_is_bound env new_value 202 | Send { kind; meth; obj; args; dbg; } -> 203 ignore_meth_kind kind; 204 check_variable_is_bound env meth; 205 check_variable_is_bound env obj; 206 check_variables_are_bound env args; 207 ignore_debuginfo dbg 208 | If_then_else (cond, ifso, ifnot) -> 209 check_variable_is_bound env cond; 210 loop env ifso; 211 loop env ifnot 212 | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) -> 213 check_variable_is_bound env arg; 214 ignore_int_set numconsts; 215 ignore_int_set numblocks; 216 List.iter (fun (n, e) -> 217 ignore_int n; 218 loop env e) 219 (consts @ blocks); 220 Misc.may (loop env) failaction 221 | String_switch (arg, cases, e_opt) -> 222 check_variable_is_bound env arg; 223 List.iter (fun (label, case) -> 224 ignore_string label; 225 loop env case) 226 cases; 227 Misc.may (loop env) e_opt 228 | Static_raise (static_exn, es) -> 229 ignore_static_exception static_exn; 230 List.iter (check_variable_is_bound env) es 231 | While (e1, e2) -> 232 loop env e1; 233 loop env e2 234 | Proved_unreachable -> () 235 and loop_named env (named : Flambda.named) = 236 match named with 237 | Symbol symbol -> check_symbol_is_bound env symbol 238 | Const const -> ignore_const const 239 | Allocated_const const -> ignore_allocated_const const 240 | Read_mutable mut_var -> 241 check_mutable_variable_is_bound env mut_var 242 | Read_symbol_field (symbol, index) -> 243 check_symbol_is_bound env symbol; 244 assert (index >= 0) (* CR-someday mshinwell: add proper error *) 245 | Set_of_closures set_of_closures -> 246 loop_set_of_closures env set_of_closures 247 | Project_closure { set_of_closures; closure_id; } -> 248 check_variable_is_bound env set_of_closures; 249 ignore_closure_id closure_id 250 | Move_within_set_of_closures { closure; start_from; move_to; } -> 251 check_variable_is_bound env closure; 252 ignore_closure_id start_from; 253 ignore_closure_id move_to; 254 | Project_var { closure; closure_id; var; } -> 255 check_variable_is_bound env closure; 256 ignore_closure_id closure_id; 257 ignore_var_within_closure var 258 | Prim (prim, args, dbg) -> 259 ignore_primitive prim; 260 check_variables_are_bound env args; 261 ignore_debuginfo dbg 262 | Expr expr -> 263 loop env expr 264 and loop_set_of_closures env 265 ({ Flambda.function_decls; free_vars; specialised_args; 266 direct_call_surrogates = _; } as set_of_closures) = 267 (* CR-soon mshinwell: check [direct_call_surrogates] *) 268 let { Flambda.set_of_closures_id; set_of_closures_origin; funs; } = 269 function_decls 270 in 271 ignore_set_of_closures_id set_of_closures_id; 272 ignore_set_of_closures_origin set_of_closures_origin; 273 let functions_in_closure = Variable.Map.keys funs in 274 let variables_in_closure = 275 Variable.Map.fold (fun var (var_in_closure : Flambda.specialised_to) 276 variables_in_closure -> 277 (* [var] may occur in the body, but will effectively be renamed 278 to [var_in_closure], so the latter is what we check to make 279 sure it's bound. *) 280 ignore_variable var; 281 check_variable_is_bound env var_in_closure.var; 282 Variable.Set.add var variables_in_closure) 283 free_vars Variable.Set.empty 284 in 285 let all_params, all_free_vars = 286 Variable.Map.fold (fun fun_var function_decl acc -> 287 let all_params, all_free_vars = acc in 288 (* CR-soon mshinwell: check function_decl.all_symbols *) 289 let { Flambda.params; body; free_variables; stub; dbg; _ } = 290 function_decl 291 in 292 assert (Variable.Set.mem fun_var functions_in_closure); 293 ignore_bool stub; 294 ignore_debuginfo dbg; 295 (* Check that [free_variables], which is only present as an 296 optimization, is not lying. *) 297 let free_variables' = Flambda.free_variables body in 298 if not (Variable.Set.subset free_variables' free_variables) then 299 raise (Free_variables_set_is_lying (fun_var, 300 free_variables, free_variables', function_decl)); 301 (* Check that every variable free in the body of the function is 302 bound by either the set of closures or the parameter list. *) 303 let acceptable_free_variables = 304 Variable.Set.union 305 (Variable.Set.union variables_in_closure functions_in_closure) 306 (Variable.Set.of_list params) 307 in 308 let bad = 309 Variable.Set.diff free_variables acceptable_free_variables 310 in 311 if not (Variable.Set.is_empty bad) then begin 312 raise (Vars_in_function_body_not_bound_by_closure_or_params 313 (bad, set_of_closures, fun_var)) 314 end; 315 (* Check that parameters are unique across all functions in the 316 declaration. *) 317 let old_all_params_size = Variable.Set.cardinal all_params in 318 let params = Variable.Set.of_list params in 319 let params_size = Variable.Set.cardinal params in 320 let all_params = Variable.Set.union all_params params in 321 let all_params_size = Variable.Set.cardinal all_params in 322 if all_params_size <> old_all_params_size + params_size then begin 323 raise (Function_decls_have_overlapping_parameters all_params) 324 end; 325 (* Check that parameters and function variables are not 326 bound somewhere else in the program *) 327 declare_variables params; 328 declare_variable fun_var; 329 (* Check that the body of the functions is correctly structured *) 330 let body_env = 331 let (var_env, _, sym_env) = env in 332 let var_env = 333 Variable.Set.fold (fun var -> Variable.Set.add var) 334 free_variables var_env 335 in 336 (* Mutable variables cannot be captured by closures *) 337 let mut_env = Mutable_variable.Set.empty in 338 (var_env, mut_env, sym_env) 339 in 340 loop body_env body; 341 all_params, Variable.Set.union free_variables all_free_vars) 342 funs (Variable.Set.empty, Variable.Set.empty) 343 in 344 (* CR-soon pchambart: This is not a property that we can certainly 345 ensure. 346 If the function get inlined, it is possible for the inlined version 347 to still use that variable. To be able to ensure that, we need to 348 also ensure that the inlined version will certainly be transformed 349 in a same way that can drop the dependency. 350 mshinwell: This should get some thought after the first release to 351 decide for sure what to do. *) 352 (* Check that the free variables rewriting map in the set of closures 353 does not contain variables in its domain that are not actually free 354 variables of any of the function bodies. *) 355 let bad_free_vars = 356 Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars 357 in 358(* 359 if not (Variable.Set.is_empty bad_free_vars) then begin 360 raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars) 361 end; 362*) 363 (* CR-someday pchambart: Ignore it to avoid the warning: get rid of that 364 when the case is settled *) 365 ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars); 366 (* Check that free variables are not bound somewhere 367 else in the program *) 368 declare_variables (Variable.Map.keys free_vars); 369 (* Check that every "specialised arg" is a parameter of one of the 370 functions being declared, and that the variable to which the 371 parameter is being specialised is bound. *) 372 Variable.Map.iter (fun _inner_var 373 (specialised_to : Flambda.specialised_to) -> 374 check_variable_is_bound env specialised_to.var; 375 match specialised_to.projection with 376 | None -> () 377 | Some projection -> 378 let projecting_from = Projection.projecting_from projection in 379 if not (Variable.Map.mem projecting_from free_vars) 380 then begin 381 raise (Projection_must_be_a_free_var projection) 382 end) 383 free_vars; 384 Variable.Map.iter (fun being_specialised 385 (specialised_to : Flambda.specialised_to) -> 386 if not (Variable.Set.mem being_specialised all_params) then begin 387 raise (Specialised_arg_that_is_not_a_parameter being_specialised) 388 end; 389 check_variable_is_bound env specialised_to.var; 390 match specialised_to.projection with 391 | None -> () 392 | Some projection -> 393 let projecting_from = Projection.projecting_from projection in 394 if not (Variable.Map.mem projecting_from specialised_args) 395 then begin 396 raise (Projection_must_be_a_specialised_arg projection) 397 end) 398 specialised_args 399 in 400 let loop_constant_defining_value env 401 (const : Flambda.constant_defining_value) = 402 match const with 403 | Flambda.Allocated_const c -> 404 ignore_allocated_const c 405 | Flambda.Block (tag,fields) -> 406 ignore_tag tag; 407 List.iter (fun (fields : Flambda.constant_defining_value_block_field) -> 408 match fields with 409 | Const c -> ignore_const c 410 | Symbol s -> check_symbol_is_bound env s) 411 fields 412 | Flambda.Set_of_closures set_of_closures -> 413 loop_set_of_closures env set_of_closures; 414 (* Constant set of closures must not have free variables *) 415 if not (Variable.Map.is_empty set_of_closures.free_vars) then 416 assert false; (* TODO: correct error *) 417 if not (Variable.Map.is_empty set_of_closures.specialised_args) then 418 assert false; (* TODO: correct error *) 419 | Flambda.Project_closure (symbol,closure_id) -> 420 ignore_closure_id closure_id; 421 check_symbol_is_bound env symbol 422 in 423 let rec loop_program_body env (program : Flambda.program_body) = 424 match program with 425 | Let_rec_symbol (defs, program) -> 426 let env = 427 List.fold_left (fun env (symbol, _) -> 428 add_binding_occurrence_of_symbol env symbol) 429 env defs 430 in 431 List.iter (fun (_, def) -> 432 loop_constant_defining_value env def) 433 defs; 434 loop_program_body env program 435 | Let_symbol (symbol, def, program) -> 436 loop_constant_defining_value env def; 437 let env = add_binding_occurrence_of_symbol env symbol in 438 loop_program_body env program 439 | Initialize_symbol (symbol, _tag, fields, program) -> 440 List.iter (loop env) fields; 441 let env = add_binding_occurrence_of_symbol env symbol in 442 loop_program_body env program 443 | Effect (expr, program) -> 444 loop env expr; 445 loop_program_body env program 446 | End root -> 447 check_symbol_is_bound env root 448 in 449 let env = 450 Symbol.Set.fold (fun symbol env -> 451 add_binding_occurrence_of_symbol env symbol) 452 program.imported_symbols 453 (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty) 454 in 455 loop_program_body env program.program_body 456 457let primitive_invariants flam ~no_access_to_global_module_identifiers = 458 Flambda_iterators.iter_named (function 459 | Prim (prim, _, _) -> 460 begin match prim with 461 | Psequand | Psequor -> 462 raise (Sequential_logical_operator_primitives_must_be_expanded prim) 463 | Pgetglobal id -> 464 if no_access_to_global_module_identifiers 465 && not (Ident.is_predef_exn id) then 466 begin 467 raise (Access_to_global_module_identifier prim) 468 end 469 | Pidentity -> raise Pidentity_should_not_occur 470 | Pdirapply -> raise Pdirapply_should_be_expanded 471 | Prevapply -> raise Prevapply_should_be_expanded 472 | Ploc _ -> raise Ploc_should_be_expanded 473 | _ -> () 474 end 475 | _ -> ()) 476 flam 477 478let declared_var_within_closure (flam:Flambda.program) = 479 let bound = ref Var_within_closure.Set.empty in 480 let bound_multiple_times = ref None in 481 let add_and_check var = 482 if Var_within_closure.Set.mem var !bound then begin 483 bound_multiple_times := Some var 484 end; 485 bound := Var_within_closure.Set.add var !bound 486 in 487 Flambda_iterators.iter_on_set_of_closures_of_program 488 ~f:(fun ~constant:_ { Flambda. free_vars; _ } -> 489 Variable.Map.iter (fun id _ -> 490 let var = Var_within_closure.wrap id in 491 add_and_check var) 492 free_vars) 493 flam; 494 !bound, !bound_multiple_times 495 496let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) = 497 match declared_var_within_closure flam with 498 | _, Some var -> raise (Var_within_closure_bound_multiple_times var) 499 | _, None -> () 500 501let every_declared_closure_is_from_current_compilation_unit flam = 502 let current_compilation_unit = Compilation_unit.get_current_exn () in 503 Flambda_iterators.iter_on_sets_of_closures (fun 504 { Flambda. function_decls; _ } -> 505 let compilation_unit = 506 Set_of_closures_id.get_compilation_unit 507 function_decls.set_of_closures_id 508 in 509 if not (Compilation_unit.equal compilation_unit current_compilation_unit) 510 then raise (Declared_closure_from_another_unit compilation_unit)) 511 flam 512 513let declared_closure_ids program = 514 let bound = ref Closure_id.Set.empty in 515 let bound_multiple_times = ref None in 516 let add_and_check var = 517 if Closure_id.Set.mem var !bound 518 then bound_multiple_times := Some var; 519 bound := Closure_id.Set.add var !bound 520 in 521 Flambda_iterators.iter_on_set_of_closures_of_program program 522 ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> 523 Variable.Map.iter (fun id _ -> 524 let var = Closure_id.wrap id in 525 add_and_check var) 526 function_decls.funs); 527 !bound, !bound_multiple_times 528 529let no_closure_id_is_bound_multiple_times program = 530 match declared_closure_ids program with 531 | _, Some closure_id -> 532 raise (Closure_id_is_bound_multiple_times closure_id) 533 | _, None -> () 534 535let declared_set_of_closures_ids program = 536 let bound = ref Set_of_closures_id.Set.empty in 537 let bound_multiple_times = ref None in 538 let add_and_check var = 539 if Set_of_closures_id.Set.mem var !bound 540 then bound_multiple_times := Some var; 541 bound := Set_of_closures_id.Set.add var !bound 542 in 543 Flambda_iterators.iter_on_set_of_closures_of_program program 544 ~f:(fun ~constant:_ { Flambda. function_decls; _; } -> 545 add_and_check function_decls.set_of_closures_id); 546 !bound, !bound_multiple_times 547 548let no_set_of_closures_id_is_bound_multiple_times program = 549 match declared_set_of_closures_ids program with 550 | _, Some set_of_closures_id -> 551 raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id) 552 | _, None -> () 553 554let used_closure_ids (program:Flambda.program) = 555 let used = ref Closure_id.Set.empty in 556 let f (flam : Flambda.named) = 557 match flam with 558 | Project_closure { closure_id; _} -> 559 used := Closure_id.Set.add closure_id !used; 560 | Move_within_set_of_closures { closure = _; start_from; move_to; } -> 561 used := Closure_id.Set.add start_from !used; 562 used := Closure_id.Set.add move_to !used 563 | Project_var { closure = _; closure_id; var = _ } -> 564 used := Closure_id.Set.add closure_id !used 565 | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _ 566 | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> () 567 in 568 (* CR-someday pchambart: check closure_ids of constant_defining_values' 569 project_closures *) 570 Flambda_iterators.iter_named_of_program ~f program; 571 !used 572 573let used_vars_within_closures (flam:Flambda.program) = 574 let used = ref Var_within_closure.Set.empty in 575 let f (flam : Flambda.named) = 576 match flam with 577 | Project_var { closure = _; closure_id = _; var; } -> 578 used := Var_within_closure.Set.add var !used 579 | _ -> () 580 in 581 Flambda_iterators.iter_named_of_program ~f flam; 582 !used 583 584let every_used_function_from_current_compilation_unit_is_declared 585 (program:Flambda.program) = 586 let current_compilation_unit = Compilation_unit.get_current_exn () in 587 let declared, _ = declared_closure_ids program in 588 let used = used_closure_ids program in 589 let used_from_current_unit = 590 Closure_id.Set.filter (fun cu -> 591 Closure_id.in_compilation_unit cu current_compilation_unit) 592 used 593 in 594 let counter_examples = 595 Closure_id.Set.diff used_from_current_unit declared 596 in 597 if Closure_id.Set.is_empty counter_examples 598 then () 599 else raise (Unbound_closure_ids counter_examples) 600 601let every_used_var_within_closure_from_current_compilation_unit_is_declared 602 (flam:Flambda.program) = 603 let current_compilation_unit = Compilation_unit.get_current_exn () in 604 let declared, _ = declared_var_within_closure flam in 605 let used = used_vars_within_closures flam in 606 let used_from_current_unit = 607 Var_within_closure.Set.filter (fun cu -> 608 Var_within_closure.in_compilation_unit cu current_compilation_unit) 609 used 610 in 611 let counter_examples = 612 Var_within_closure.Set.diff used_from_current_unit declared in 613 if Var_within_closure.Set.is_empty counter_examples 614 then () 615 else raise (Unbound_vars_within_closures counter_examples) 616 617let every_static_exception_is_caught flam = 618 let check env (flam : Flambda.t) = 619 match flam with 620 | Static_raise (exn, _) -> 621 if not (Static_exception.Set.mem exn env) 622 then raise (Static_exception_not_caught exn) 623 | _ -> () 624 in 625 let rec loop env (flam : Flambda.t) = 626 match flam with 627 | Static_catch (i, _, body, handler) -> 628 let env = Static_exception.Set.add i env in 629 loop env handler; 630 loop env body 631 | exp -> 632 check env exp; 633 Flambda_iterators.apply_on_subexpressions (loop env) 634 (fun (_ : Flambda.named) -> ()) exp 635 in 636 loop Static_exception.Set.empty flam 637 638let every_static_exception_is_caught_at_a_single_position flam = 639 let caught = ref Static_exception.Set.empty in 640 let f (flam : Flambda.t) = 641 match flam with 642 | Static_catch (i, _, _body, _handler) -> 643 if Static_exception.Set.mem i !caught then 644 raise (Static_exception_caught_in_multiple_places i); 645 caught := Static_exception.Set.add i !caught 646 | _ -> () 647 in 648 Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam 649 650let _every_move_within_set_of_closures_is_to_a_function_in_the_free_vars 651 program = 652 let moves = ref Closure_id.Map.empty in 653 Flambda_iterators.iter_named_of_program program 654 ~f:(function 655 | Move_within_set_of_closures { start_from; move_to; _ } -> 656 let moved_to = 657 try Closure_id.Map.find start_from !moves with 658 | Not_found -> Closure_id.Set.empty 659 in 660 moves := 661 Closure_id.Map.add start_from 662 (Closure_id.Set.add move_to moved_to) 663 !moves 664 | _ -> ()); 665 Flambda_iterators.iter_on_set_of_closures_of_program program 666 ~f:(fun ~constant:_ { Flambda.function_decls = { funs; _ }; _ } -> 667 Variable.Map.iter (fun fun_var { Flambda.free_variables; _ } -> 668 match Closure_id.Map.find (Closure_id.wrap fun_var) !moves with 669 | exception Not_found -> () 670 | moved_to -> 671 let missing_dependencies = 672 Variable.Set.diff (Closure_id.unwrap_set moved_to) 673 free_variables 674 in 675 if not (Variable.Set.is_empty missing_dependencies) then 676 raise (Move_to_a_closure_not_in_the_free_variables 677 (fun_var, missing_dependencies))) 678 funs) 679 680let check_exn ?(kind=Normal) ?(cmxfile=false) (flam:Flambda.program) = 681 ignore kind; 682 try 683 variable_and_symbol_invariants flam; 684 no_closure_id_is_bound_multiple_times flam; 685 no_set_of_closures_id_is_bound_multiple_times flam; 686 every_used_function_from_current_compilation_unit_is_declared flam; 687 no_var_within_closure_is_bound_multiple_times flam; 688 every_used_var_within_closure_from_current_compilation_unit_is_declared 689 flam; 690 (* CR-soon pchambart: This invariant is not maintained. It should be 691 either relaxed or reformulated. Currently, it is safe to disable it as 692 the potential related errors would result in fatal errors, not in 693 miscompilations *) 694 (* every_move_within_set_of_closures_is_to_a_function_in_the_free_vars 695 flam; *) 696 Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam -> 697 primitive_invariants flam ~no_access_to_global_module_identifiers:cmxfile; 698 every_static_exception_is_caught flam; 699 every_static_exception_is_caught_at_a_single_position flam; 700 every_declared_closure_is_from_current_compilation_unit flam) 701 with exn -> begin 702 (* CR-someday split printing code into its own function *) 703 begin match exn with 704 | Binding_occurrence_not_from_current_compilation_unit var -> 705 Format.eprintf ">> Binding occurrence of variable marked as not being \ 706 from the current compilation unit: %a" 707 Variable.print var 708 | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var -> 709 Format.eprintf ">> Binding occurrence of mutable variable marked as not \ 710 being from the current compilation unit: %a" 711 Mutable_variable.print mut_var 712 | Binding_occurrence_of_variable_already_bound var -> 713 Format.eprintf ">> Binding occurrence of variable that was already \ 714 bound: %a" 715 Variable.print var 716 | Binding_occurrence_of_mutable_variable_already_bound mut_var -> 717 Format.eprintf ">> Binding occurrence of mutable variable that was \ 718 already bound: %a" 719 Mutable_variable.print mut_var 720 | Binding_occurrence_of_symbol_already_bound sym -> 721 Format.eprintf ">> Binding occurrence of symbol that was already \ 722 bound: %a" 723 Symbol.print sym 724 | Unbound_variable var -> 725 Format.eprintf ">> Unbound variable: %a" Variable.print var 726 | Unbound_mutable_variable mut_var -> 727 Format.eprintf ">> Unbound mutable variable: %a" 728 Mutable_variable.print mut_var 729 | Unbound_symbol sym -> 730 Format.eprintf ">> Unbound symbol: %a %s" 731 Symbol.print sym 732 (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100)) 733 | Vars_in_function_body_not_bound_by_closure_or_params 734 (vars, set_of_closures, fun_var) -> 735 Format.eprintf ">> Variable(s) (%a) in the body of a function \ 736 declaration (fun_var = %a) that is not bound by either the closure \ 737 or the function's parameter list. Set of closures: %a" 738 Variable.Set.print vars 739 Variable.print fun_var 740 Flambda.print_set_of_closures set_of_closures 741 | Function_decls_have_overlapping_parameters vars -> 742 Format.eprintf ">> Function declarations whose parameters overlap: \ 743 %a" 744 Variable.Set.print vars 745 | Specialised_arg_that_is_not_a_parameter var -> 746 Format.eprintf ">> Variable in [specialised_args] that is not a \ 747 parameter of any of the function(s) in the corresponding \ 748 declaration(s): %a" 749 Variable.print var 750 | Projection_must_be_a_free_var var -> 751 Format.eprintf ">> Projection %a in [free_vars] from a variable that is \ 752 not a (inner) free variable of the set of closures" 753 Projection.print var 754 | Projection_must_be_a_specialised_arg var -> 755 Format.eprintf ">> Projection %a in [specialised_args] from a variable \ 756 that is not a (inner) specialised argument variable of the set of \ 757 closures" 758 Projection.print var 759 | Free_variables_set_is_lying (var, claimed, calculated, function_decl) -> 760 Format.eprintf ">> Function declaration whose [free_variables] set (%a) \ 761 is not a superset of the result of [Flambda.free_variables] \ 762 applied to the body of the function (%a). Declaration: %a" 763 Variable.Set.print claimed 764 Variable.Set.print calculated 765 Flambda.print_function_declaration (var, function_decl) 766 | Set_of_closures_free_vars_map_has_wrong_range vars -> 767 Format.eprintf ">> [free_vars] map in set of closures has in its range \ 768 variables that are not free variables of the corresponding \ 769 functions: %a" 770 Variable.Set.print vars 771 | Sequential_logical_operator_primitives_must_be_expanded prim -> 772 Format.eprintf ">> Sequential logical operator primitives must be \ 773 expanded (see closure_conversion.ml): %a" 774 Printlambda.primitive prim 775 | Var_within_closure_bound_multiple_times var -> 776 Format.eprintf ">> Variable within a closure is bound multiple times: \ 777 %a" 778 Var_within_closure.print var 779 | Closure_id_is_bound_multiple_times closure_id -> 780 Format.eprintf ">> Closure ID is bound multiple times: %a" 781 Closure_id.print closure_id 782 | Set_of_closures_id_is_bound_multiple_times set_of_closures_id -> 783 Format.eprintf ">> Set of closures ID is bound multiple times: %a" 784 Set_of_closures_id.print set_of_closures_id 785 | Declared_closure_from_another_unit compilation_unit -> 786 Format.eprintf ">> Closure declared as being from another compilation \ 787 unit: %a" 788 Compilation_unit.print compilation_unit 789 | Unbound_closure_ids closure_ids -> 790 Format.eprintf ">> Unbound closure ID(s) from the current compilation \ 791 unit: %a" 792 Closure_id.Set.print closure_ids 793 | Unbound_vars_within_closures vars_within_closures -> 794 Format.eprintf ">> Unbound variable(s) within closure(s) from the \ 795 current compilation_unit: %a" 796 Var_within_closure.Set.print vars_within_closures 797 | Static_exception_not_caught static_exn -> 798 Format.eprintf ">> Uncaught static exception: %a" 799 Static_exception.print static_exn 800 | Static_exception_caught_in_multiple_places static_exn -> 801 Format.eprintf ">> Static exception caught in multiple places: %a" 802 Static_exception.print static_exn 803 | Access_to_global_module_identifier prim -> 804 (* CR-someday mshinwell: backend-specific checks should move to another 805 module, in the asmcomp/ directory. *) 806 Format.eprintf ">> Forbidden access to a global module identifier (not \ 807 allowed in Flambda that will be exported to a .cmx file): %a" 808 Printlambda.primitive prim 809 | Pidentity_should_not_occur -> 810 Format.eprintf ">> The Pidentity primitive should never occur in an \ 811 Flambda expression (see closure_conversion.ml)" 812 | Pdirapply_should_be_expanded -> 813 Format.eprintf ">> The Pdirapply primitive should never occur in an \ 814 Flambda expression (see simplif.ml); use Apply instead" 815 | Prevapply_should_be_expanded -> 816 Format.eprintf ">> The Prevapply primitive should never occur in an \ 817 Flambda expression (see simplif.ml); use Apply instead" 818 | Ploc_should_be_expanded -> 819 Format.eprintf ">> The Ploc primitive should never occur in an \ 820 Flambda expression (see translcore.ml); use Apply instead" 821 | Move_to_a_closure_not_in_the_free_variables (start_from, move_to) -> 822 Format.eprintf ">> A Move_within_set_of_closures from the closure %a \ 823 to closures that are not parts of its free variables: %a" 824 Variable.print start_from 825 Variable.Set.print move_to 826 | exn -> raise exn 827 end; 828 Format.eprintf "\n@?"; 829 raise Flambda_invariants_failed 830 end 831