The unpac monorepo manager self-hosting as a monorepo using unpac
Merge commit '758fc7ddd609fd51ff811db2af5393672b2ef37c' into 5.00
+229
-75
+20
Changes
+20
Changes
···
23
23
24
24
### Tools:
25
25
26
+
- #3959, #7202, #10476: ocaml, in script mode, directive errors
27
+
(`#use "missing_file";;`) use stderr and exit with an error.
28
+
(Florian Angeletti, review by Gabriel Scherer)
29
+
26
30
### Manual and documentation:
27
31
28
32
- #7812, #10475: reworded the description of the behaviors of
···
59
63
- #10472: refactor caml_sys_random_seed to ease future Multicore changes
60
64
(Gabriel Scherer, review by Xavier Leroy)
61
65
66
+
- #10487: Move logic to get the type path from a constructor return type in
67
+
Types
68
+
(Nicolas Chataing, review by Jacques Garrigue)
69
+
62
70
### Build system:
63
71
64
72
### Bug fixes:
···
67
75
This allows stacktraces to work in gdb through C and OCaml calls.
68
76
(Edwin Török, review by Nicolás Ojeda Bär and Xavier Leroy)
69
77
78
+
- #10461: `caml_send*` helper functions take derived pointers as arguments.
79
+
Those must be declared with type Addr instead of Val.
80
+
(Vincent Laviron, review by Xavier Leroy)
81
+
82
+
70
83
OCaml 4.13.0
71
84
-------------
72
85
73
86
### Language features:
87
+
88
+
- #10039: Safepoints
89
+
Add poll points to native generated code. These are effectively
90
+
zero-sized allocations and fix some signal and remembered set
91
+
issues. Also multicore prerequisite.
92
+
(Sadiq Jaffer, Damien Doligez, Mark Shinwell, Anmol Sahoo, Stephen Dolan,
93
+
Xavier Leroy reviewed by ??)
74
94
75
95
- #9331: Improve error messages for functor application and functor types.
76
96
(Florian Angeletti and Gabriel Radanne, review by Leo White)
+3
INSTALL.adoc
+3
INSTALL.adoc
···
20
20
* Under Cygwin, the `gcc-core` package is required. `flexdll` is also necessary
21
21
for shared library support.
22
22
23
+
* Binutils including `ar`, `ranlib`, and `strip` are required if your
24
+
distribution does not already provide them with the C compiler.
25
+
23
26
== Configuration
24
27
25
28
From the top directory, do:
+41
-1
asmcomp/arm64/emit.mlp
+41
-1
asmcomp/arm64/emit.mlp
···
410
410
loop instr.next (call_gc + 1, check_bound)
411
411
| Lop (Ipoll _) ->
412
412
loop instr.next (call_gc + 1, check_bound)
413
+
| Lop (Ipoll _) ->
414
+
loop instr.next (call_gc + 1, check_bound)
413
415
| Lop (Iintop Icheckbound)
414
416
| Lop (Iintop_imm (Icheckbound, _))
415
417
| Lop (Ispecific (Ishiftcheckbound _)) ->
···
644
646
` and {emit_reg r}, {emit_reg reg_alloc_ptr}, #{emit_nativeint dom_mask}\n`;
645
647
` ldr {emit_reg r}, [{emit_reg r}, #{emit_int domain_field}]`
646
648
649
+
let assembly_code_for_poll env i ~far ~return_label =
650
+
let lbl_frame = record_frame_label env i.live (Dbg_alloc []) in
651
+
let lbl_call_gc = new_label() in
652
+
let lbl_after_poll = match return_label with
653
+
| None -> new_label()
654
+
| Some lbl -> lbl in
655
+
let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
656
+
` ldr {emit_reg reg_tmp1}, [{emit_reg reg_domain_state_ptr}, #{emit_int offset}]\n`;
657
+
` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_tmp1}\n`;
658
+
if not far then begin
659
+
match return_label with
660
+
| None ->
661
+
` b.ls {emit_label lbl_call_gc}\n`;
662
+
`{emit_label lbl_after_poll}:\n`
663
+
| Some return_label ->
664
+
` b.hi {emit_label return_label}\n`;
665
+
` b {emit_label lbl_call_gc}\n`;
666
+
end else begin
667
+
match return_label with
668
+
| None ->
669
+
` b.hi {emit_label lbl_after_poll}\n`;
670
+
` b {emit_label lbl_call_gc}\n`;
671
+
`{emit_label lbl_after_poll}:\n`
672
+
| Some return_label ->
673
+
let lbl = new_label () in
674
+
` b.ls {emit_label lbl}\n`;
675
+
` b {emit_label return_label}\n`;
676
+
`{emit_label lbl}: b {emit_label lbl_call_gc}\n`
677
+
end;
678
+
env.call_gc_sites <-
679
+
{ gc_lbl = lbl_call_gc;
680
+
gc_return_lbl = lbl_after_poll;
681
+
gc_frame_lbl = lbl_frame; } :: env.call_gc_sites
682
+
647
683
(* Output .text section directive, or named .text.caml.<name> if enabled. *)
648
684
649
685
let emit_named_text_section func_name =
···
803
839
| Lop(Ialloc { bytes = n; dbginfo }) ->
804
840
assembly_code_for_allocation i ~n ~far:false ~dbginfo
805
841
| Lop(Ispecific (Ifar_alloc { bytes = n; dbginfo })) ->
806
-
assembly_code_for_allocation i ~n ~far:true ~dbginfo
842
+
assembly_code_for_allocation env i ~n ~far:true ~dbginfo
843
+
| Lop(Ipoll { return_label }) ->
844
+
assembly_code_for_poll env i ~far:false ~return_label
845
+
| Lop(Ispecific (Ifar_poll { return_label })) ->
846
+
assembly_code_for_poll env i ~far:true ~return_label
807
847
| Lop(Iintop_imm(Iadd, n)) ->
808
848
emit_addimm i.res.(0) i.arg.(0) n
809
849
| Lop(Iintop_imm(Isub, n)) ->
+5
-7
asmcomp/arm64/proc.ml
+5
-7
asmcomp/arm64/proc.ml
···
257
257
let destroyed_at_oper = function
258
258
| Iop(Icall_ind | Icall_imm _) | Iop(Iextcall { alloc = true; }) ->
259
259
all_phys_regs
260
-
| Iop(Iextcall { alloc ; stack_ofs; }) ->
261
-
assert (stack_ofs >= 0);
262
-
if alloc || stack_ofs > 0 then all_phys_regs
263
-
else destroyed_at_c_call
264
-
| Iop(Ialloc _) ->
260
+
| Iop(Iextcall { alloc = false; }) ->
261
+
destroyed_at_c_call
262
+
| Iop(Ialloc _) | Iop(Ipoll _) ->
265
263
[| reg_x8 |]
266
264
| Iop( Iintoffloat | Ifloatofint
267
265
| Iload(Single, _, _) | Istore(Single, _, _)) ->
···
276
274
277
275
let safe_register_pressure = function
278
276
| Iextcall _ -> 7
279
-
| Ialloc _ -> 22
277
+
| Ialloc _ | Ipoll _ -> 22
280
278
| _ -> 23
281
279
282
280
let max_register_pressure = function
283
281
| Iextcall _ -> [| 7; 8 |] (* 7 integer callee-saves, 8 FP callee-saves *)
284
-
| Ialloc _ -> [| 22; 32 |]
282
+
| Ialloc _ | Ipoll _ -> [| 22; 32 |]
285
283
| Iintoffloat | Ifloatofint
286
284
| Iload(Single, _, _) | Istore(Single, _, _) -> [| 23; 31 |]
287
285
| _ -> [| 23; 32 |]
+4
-3
asmcomp/asmgen.ml
+4
-3
asmcomp/asmgen.ml
···
138
138
Reg.reset();
139
139
fd_cmm
140
140
++ Profile.record ~accumulate:true "cmm_invariants" (cmm_invariants ppf_dump)
141
-
++ Profile.record ~accumulate:true "selection" (Selection.fundecl ~future_funcnames:funcnames)
141
+
++ Profile.record ~accumulate:true "selection"
142
+
(Selection.fundecl ~future_funcnames:funcnames)
143
+
++ Profile.record ~accumulate:true "polling"
144
+
(Polling.instrument_fundecl ~future_funcnames:funcnames)
142
145
++ pass_dump_if ppf_dump dump_selection "After instruction selection"
143
146
++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl
144
147
++ pass_dump_if ppf_dump dump_combine "After allocation combining"
···
146
149
++ pass_dump_if ppf_dump dump_cse "After CSE"
147
150
++ Profile.record ~accumulate:true "liveness" liveness
148
151
++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
149
-
++ Profile.record ~accumulate:true "polling"
150
-
(Polling.instrument_fundecl ~future_funcnames:funcnames)
151
152
++ pass_dump_if ppf_dump dump_live "Liveness analysis"
152
153
++ Profile.record ~accumulate:true "spill" Spill.fundecl
153
154
++ Profile.record ~accumulate:true "liveness" liveness
+9
asmcomp/branch_relaxation.ml
+9
asmcomp/branch_relaxation.ml
···
51
51
in
52
52
match instr.desc with
53
53
| Lop (Ialloc _)
54
+
| Lop (Ipoll { return_label = None })
54
55
| Lop (Iintop (Icheckbound))
55
56
| Lop (Iintop_imm (Icheckbound, _))
56
57
| Lop (Ispecific _) ->
···
64
65
opt_branch_overflows map pc lbl0 max_branch_offset
65
66
|| opt_branch_overflows map pc lbl1 max_branch_offset
66
67
|| opt_branch_overflows map pc lbl2 max_branch_offset
68
+
| Lop (Ipoll { return_label = Some lbl }) ->
69
+
(* A poll-and-branch instruction can branch to the label lbl,
70
+
but also to an out-of-line code block. *)
71
+
code_size + max_out_of_line_code_offset - pc >= max_branch_offset
72
+
|| branch_overflows map pc lbl max_branch_offset
67
73
| _ ->
68
74
Misc.fatal_error "Unsupported instruction for branch relaxation"
69
75
···
86
92
fixup did_fix (pc + T.instr_size f instr.desc) instr.next
87
93
else
88
94
match instr.desc with
95
+
| Lop (Ipoll { return_label }) ->
96
+
instr.desc <- T.relax_poll ~return_label;
97
+
fixup true (pc + T.instr_size f instr.desc) instr.next
89
98
| Lop (Ialloc { bytes = num_bytes; dbginfo }) ->
90
99
instr.desc <- T.relax_allocation ~num_bytes ~dbginfo;
91
100
fixup true (pc + T.instr_size f instr.desc) instr.next
+1
-1
asmcomp/cmm_helpers.ml
+1
-1
asmcomp/cmm_helpers.ml
···
1877
1877
let cache = cache in
1878
1878
let fun_name = "caml_send" ^ Int.to_string arity in
1879
1879
let fun_args =
1880
-
[obj, typ_val; tag, typ_int; cache, typ_val]
1880
+
[obj, typ_val; tag, typ_int; cache, typ_addr]
1881
1881
@ List.map (fun id -> (id, typ_val)) (List.tl args) in
1882
1882
let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
1883
1883
Cfunction
+2
-1
asmcomp/i386/selection.ml
+2
-1
asmcomp/i386/selection.ml
+2
-1
asmcomp/mach.ml
+2
-1
asmcomp/mach.ml
···
149
149
150
150
let operation_is_pure = function
151
151
| Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _
152
-
| Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ | Ipoll _ | Inop | Idls_get
152
+
| Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ | Ipoll _
153
+
| Inop | Idls_get
153
154
| Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) | Iopaque -> false
154
155
| Ispecific sop -> Arch.operation_is_pure sop
155
156
| _ -> true
+2
-7
asmcomp/polling.ml
+2
-7
asmcomp/polling.ml
···
22
22
module Int = Numbers.Int
23
23
module String = Misc.Stdlib.String
24
24
25
-
(* replace with starts_with when it arrives *)
26
-
let isprefix s1 s2 =
27
-
String.length s1 <= String.length s2
28
-
&& String.sub s2 0 (String.length s1) = s1
29
-
30
25
let function_is_assumed_to_never_poll func =
31
-
isprefix "caml_apply" func
32
-
|| isprefix "caml_send" func
26
+
String.starts_with ~prefix:"caml_apply" func
27
+
|| String.starts_with ~prefix:"caml_send" func
33
28
34
29
(* Detection of recursive handlers that are not guaranteed to poll
35
30
at every loop iteration. *)
+4
-2
asmcomp/power/arch.ml
+4
-2
asmcomp/power/arch.ml
···
119
119
printreg arg.(0) printreg arg.(1) printreg arg.(2)
120
120
| Ialloc_far { bytes; _ } ->
121
121
fprintf ppf "alloc_far %d" bytes
122
+
| Ipoll_far _ ->
123
+
fprintf ppf "poll_far"
122
124
123
125
(* Specific operations that are pure *)
124
126
125
127
let operation_is_pure = function
126
-
| Ialloc_far _ -> false
128
+
| Ialloc_far _ | Ipoll_far _ -> false
127
129
| _ -> true
128
130
129
131
(* Specific operations that can raise *)
130
132
131
133
let operation_can_raise = function
132
-
| Ialloc_far _ -> true
134
+
| Ialloc_far _ | Ipoll_far _ -> true
133
135
| _ -> false
+42
asmcomp/power/emit.mlp
+42
asmcomp/power/emit.mlp
···
398
398
399
399
let classify_instr = function
400
400
| Lop (Ialloc _)
401
+
| Lop (Ipoll _)
401
402
(* [Ialloc_far] does not need to be here, since its code sequence
402
403
never involves any conditional branches that might need relaxing. *)
403
404
| Lcondbranch _
···
471
472
| Lop(Istore(_chunk, addr, _)) -> load_store_size addr
472
473
| Lop(Ialloc _) -> 5
473
474
| Lop(Ispecific(Ialloc_far _)) -> 6
475
+
| Lop(Ipoll { return_label = Some(_) }) -> 5
476
+
| Lop(Ipoll { return_label = None }) -> 3
477
+
| Lop(Ispecific(Ipoll_far { return_label = Some(_) } )) -> 5
478
+
| Lop(Ispecific(Ipoll_far { return_label = None } )) -> 4
474
479
| Lop(Iintop Imod) -> 3
475
480
| Lop(Iintop(Icomp _)) -> 4
476
481
| Lop(Iintop _) -> 1
···
500
505
let relax_allocation ~num_bytes:bytes ~dbginfo =
501
506
Lop (Ispecific (Ialloc_far { bytes; dbginfo }))
502
507
508
+
let relax_poll ~return_label =
509
+
Lop (Ispecific (Ipoll_far { return_label }))
510
+
503
511
(* [classify_addr], above, never identifies these instructions as needing
504
512
relaxing. As such, these functions should never be called. *)
505
513
let relax_specific_op _ = assert false
···
525
533
` bl {emit_label env.call_gc_label}\n`;
526
534
record_frame env i.live (Dbg_alloc dbginfo);
527
535
`{emit_label lbl}: addi {emit_reg i.res.(0)}, 31, {emit_int size_addr}\n`
536
+
end
537
+
538
+
let emit_poll env i return_label far =
539
+
if env.call_gc_label = 0 then env.call_gc_label <- new_label ();
540
+
let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
541
+
` {emit_string lg} 0, {emit_int offset}(30)\n`;
542
+
` {emit_string cmplg} 31, 0\n`;
543
+
if not far then begin
544
+
begin match return_label with
545
+
| None ->
546
+
begin
547
+
` bltl {emit_label env.call_gc_label}\n`;
548
+
record_frame env i.live (Dbg_alloc [])
549
+
end
550
+
| Some return_label ->
551
+
begin
552
+
` bltl {emit_label env.call_gc_label}\n`;
553
+
record_frame env i.live (Dbg_alloc []);
554
+
` b {emit_label return_label}\n`
555
+
end
556
+
end;
557
+
end else begin
558
+
let lbl = new_label () in
559
+
` bge {emit_label lbl}\n`;
560
+
` bl {emit_label env.call_gc_label}\n`;
561
+
record_frame env i.live (Dbg_alloc []);
562
+
` {emit_label lbl}: \n`;
563
+
match return_label with
564
+
| None -> ()
565
+
| Some return_label -> ` b {emit_label return_label}\n`
528
566
end
529
567
530
568
(* Output the assembly code for an instruction *)
···
761
799
emit_alloc env i bytes dbginfo false
762
800
| Lop(Ispecific(Ialloc_far { bytes; dbginfo })) ->
763
801
emit_alloc env i bytes dbginfo true
802
+
| Lop(Ipoll { return_label }) ->
803
+
emit_poll env i return_label false
804
+
| Lop(Ispecific(Ipoll_far { return_label })) ->
805
+
emit_poll env i return_label true
764
806
| Lop(Iintop Isub) -> (* subfc has swapped arguments *)
765
807
` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`
766
808
| Lop(Iintop Imod) ->
+18
asmcomp/riscv/emit.mlp
+18
asmcomp/riscv/emit.mlp
···
364
364
{ gc_lbl = lbl_call_gc;
365
365
gc_return_lbl = lbl_after_alloc;
366
366
gc_frame_lbl = lbl_frame_lbl } :: env.call_gc_sites
367
+
| Lop(Ipoll { return_label }) ->
368
+
let lbl_frame_lbl = record_frame_label env i.live (Dbg_alloc []) in
369
+
let lbl_after_poll = match return_label with
370
+
| None -> new_label()
371
+
| Some(lbl) -> lbl in
372
+
let lbl_call_gc = new_label () in
373
+
let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in
374
+
` ld {emit_reg reg_tmp}, {emit_int offset}({emit_reg reg_domain_state_ptr})\n`;
375
+
begin match return_label with
376
+
| None -> ` bltu {emit_reg reg_alloc_ptr}, {emit_reg reg_tmp}, {emit_label lbl_call_gc}\n`;
377
+
`{emit_label lbl_after_poll}:\n`;
378
+
| Some lbl -> ` bgeu {emit_reg reg_alloc_ptr}, {emit_reg reg_tmp}, {emit_label lbl}\n`;
379
+
` j {emit_label lbl_call_gc}\n`
380
+
end;
381
+
env.call_gc_sites <-
382
+
{ gc_lbl = lbl_call_gc;
383
+
gc_return_lbl = lbl_after_poll;
384
+
gc_frame_lbl = lbl_frame_lbl } :: env.call_gc_sites
367
385
| Lop(Iintop(Icomp cmp)) ->
368
386
begin match cmp with
369
387
| Isigned Clt ->
+1
-1
asmcomp/s390x/emit.mlp
+1
-1
asmcomp/s390x/emit.mlp
···
417
417
in
418
418
begin match return_label with
419
419
| None -> ` brcl 4, {emit_label lbl_call_gc}\n`; (* less than *)
420
-
| Some return_label -> ` brcl 10, {emit_label return_label}\n`; (* higher *)
420
+
| Some return_label -> ` brcl 10, {emit_label return_label}\n`; (* greater or equal *)
421
421
end;
422
422
env.call_gc_sites <-
423
423
{ gc_lbl = lbl_call_gc;
+2
ocamldoc/.depend
+2
ocamldoc/.depend
···
125
125
odoc_class.cmo \
126
126
../parsing/location.cmi \
127
127
../typing/ident.cmi \
128
+
../typing/btype.cmi \
128
129
../parsing/asttypes.cmi \
129
130
odoc_ast.cmi
130
131
odoc_ast.cmx : \
···
147
148
odoc_class.cmx \
148
149
../parsing/location.cmx \
149
150
../typing/ident.cmx \
151
+
../typing/btype.cmx \
150
152
../parsing/asttypes.cmi \
151
153
odoc_ast.cmi
152
154
odoc_ast.cmi : \
+1
-5
ocamldoc/odoc_ast.ml
+1
-5
ocamldoc/odoc_ast.ml
···
258
258
259
259
| Typedtree.Tpat_construct (_, cons_desc, _, _) when
260
260
(* we give a name to the parameter only if it is unit *)
261
-
(match get_desc cons_desc.cstr_res with
262
-
Tconstr (p, _, _) ->
263
-
Path.same p Predef.path_unit
264
-
| _ ->
265
-
false)
261
+
Path.same (Btype.cstr_type_path cons_desc) Predef.path_unit
266
262
->
267
263
(* a () argument, it never has description *)
268
264
Simple_name { sn_name = "()" ;
+2
-2
stdlib/string.mli
+2
-2
stdlib/string.mli
···
161
161
(** [starts_with ][~][prefix s] is [true] if and only if [s] starts with
162
162
[prefix].
163
163
164
-
@since 4.12.0 *)
164
+
@since 4.13.0 *)
165
165
166
166
val ends_with :
167
167
suffix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool
168
168
(** [ends_with suffix s] is [true] if and only if [s] ends with [suffix].
169
169
170
-
@since 4.12.0 *)
170
+
@since 4.13.0 *)
171
171
172
172
val contains_from : string -> int -> char -> bool
173
173
(** [contains_from s start c] is [true] if and only if [c] appears in [s]
+2
-2
stdlib/stringLabels.mli
+2
-2
stdlib/stringLabels.mli
···
161
161
(** [starts_with ][~][prefix s] is [true] if and only if [s] starts with
162
162
[prefix].
163
163
164
-
@since 4.12.0 *)
164
+
@since 4.13.0 *)
165
165
166
166
val ends_with :
167
167
suffix (* comment thwarts tools/sync_stdlib_docs *) :string -> string -> bool
168
168
(** [ends_with ~suffix s] is [true] if and only if [s] ends with [suffix].
169
169
170
-
@since 4.12.0 *)
170
+
@since 4.13.0 *)
171
171
172
172
val contains_from : string -> int -> char -> bool
173
173
(** [contains_from s start c] is [true] if and only if [c] appears in [s]
+8
testsuite/tests/asmgen/main.c
+8
testsuite/tests/asmgen/main.c
···
27
27
}
28
28
#endif
29
29
30
+
/* This stub isn't needed for msvc32, since it's already in asmgen_i386nt.asm */
31
+
#if !defined(_MSC_VER) || !defined(_M_IX86)
32
+
void caml_call_gc()
33
+
{
34
+
35
+
}
36
+
#endif
37
+
30
38
void caml_ml_array_bound_error(void)
31
39
{
32
40
fprintf(stderr, "Fatal error: out-of-bound access in array or string\n");
+9
testsuite/tests/tool-ocaml/directive_failure.ml
+9
testsuite/tests/tool-ocaml/directive_failure.ml
+2
-1
testsuite/tools/expect_test.ml
+2
-1
testsuite/tools/expect_test.ml
+34
-25
toplevel/topdirs.ml
+34
-25
toplevel/topdirs.ml
···
21
21
open Types
22
22
open Toploop
23
23
24
-
(* The standard output formatter *)
25
-
let std_out = std_formatter
24
+
let error_fmt () =
25
+
if !Sys.interactive then
26
+
Format.std_formatter
27
+
else
28
+
Format.err_formatter
29
+
30
+
let action_on_suberror b =
31
+
if not b && not !Sys.interactive then
32
+
raise (Compenv.Exit_with_status 125)
26
33
27
34
(* Directive sections (used in #help) *)
28
35
let section_general = "General"
···
122
129
doc = "Change the current working directory.";
123
130
}
124
131
125
-
let dir_load ppf name = ignore (Topeval.load_file false ppf name)
132
+
133
+
let with_error_fmt f x = f (error_fmt ()) x
126
134
127
-
let _ = add_directive "load" (Directive_string (dir_load std_out))
135
+
let dir_load ppf name =
136
+
action_on_suberror (Topeval.load_file false ppf name)
137
+
138
+
let _ = add_directive "load" (Directive_string (with_error_fmt dir_load))
128
139
{
129
140
section = section_run;
130
141
doc = "Load in memory a bytecode object, produced by ocamlc.";
131
142
}
132
143
133
-
let dir_load_rec ppf name = ignore (Topeval.load_file true ppf name)
144
+
let dir_load_rec ppf name =
145
+
action_on_suberror (Topeval.load_file true ppf name)
134
146
135
147
let _ = add_directive "load_rec"
136
-
(Directive_string (dir_load_rec std_out))
148
+
(Directive_string (with_error_fmt dir_load_rec))
137
149
{
138
150
section = section_run;
139
151
doc = "As #load, but loads dependencies recursively.";
···
144
156
(* Load commands from a file *)
145
157
146
158
let dir_use ppf name =
147
-
ignore (Toploop.use_input ppf (Toploop.File name))
148
-
let dir_use_output ppf name = ignore(Toploop.use_output ppf name)
159
+
action_on_suberror (Toploop.use_input ppf (Toploop.File name))
160
+
let dir_use_output ppf name = action_on_suberror (Toploop.use_output ppf name)
149
161
let dir_mod_use ppf name =
150
-
ignore (Toploop.mod_use_input ppf (Toploop.File name))
162
+
action_on_suberror (Toploop.mod_use_input ppf (Toploop.File name))
151
163
152
-
let _ = add_directive "use" (Directive_string (dir_use std_out))
164
+
let _ = add_directive "use" (Directive_string (with_error_fmt dir_use))
153
165
{
154
166
section = section_run;
155
167
doc = "Read, compile and execute source phrases from the given file.";
156
168
}
157
169
158
-
let _ = add_directive "use_output" (Directive_string (dir_use_output std_out))
170
+
let _ = add_directive "use_output"
171
+
(Directive_string (with_error_fmt dir_use_output))
159
172
{
160
173
section = section_run;
161
174
doc = "Execute a command and read, compile and execute source phrases \
162
175
from its output.";
163
176
}
164
177
165
-
let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out))
178
+
let _ = add_directive "mod_use" (Directive_string (with_error_fmt dir_mod_use))
166
179
{
167
180
section = section_run;
168
181
doc = "Usage is identical to #use but #mod_use \
···
317
330
with Exit -> ()
318
331
319
332
let _ = add_directive "install_printer"
320
-
(Directive_ident (dir_install_printer std_out))
333
+
(Directive_ident (with_error_fmt dir_install_printer))
321
334
{
322
335
section = section_print;
323
336
doc = "Registers a printer for values of a certain type.";
324
337
}
325
338
326
339
let _ = add_directive "remove_printer"
327
-
(Directive_ident (dir_remove_printer std_out))
340
+
(Directive_ident (with_error_fmt dir_remove_printer))
328
341
{
329
342
section = section_print;
330
343
doc = "Remove the named function from the table of toplevel printers.";
···
332
345
333
346
let parse_warnings ppf iserr s =
334
347
try Option.iter Location.(prerr_alert none) @@ Warnings.parse_options iserr s
335
-
with Arg.Bad err -> fprintf ppf "%s.@." err
348
+
with Arg.Bad err -> fprintf ppf "%s.@." err; action_on_suberror true
336
349
337
350
(* Typing information *)
338
351
···
383
396
all_show_funs := to_sig :: !all_show_funs;
384
397
add_directive
385
398
name
386
-
(Directive_ident (show_prim to_sig std_out))
399
+
(Directive_ident (show_prim to_sig std_formatter))
387
400
{
388
401
section = section_env;
389
402
doc;
···
454
467
let desc = Env.lookup_constructor ~loc Env.Positive lid env in
455
468
if is_exception_constructor env desc.cstr_res then
456
469
raise Not_found;
457
-
let path =
458
-
match get_desc desc.cstr_res with
459
-
| Tconstr(path, _, _) -> path
460
-
| _ -> raise Not_found
461
-
in
470
+
let path = Btype.cstr_type_path desc in
462
471
let type_decl = Env.find_type path env in
463
472
if is_extension_constructor desc.cstr_tag then
464
473
let ret_type =
···
584
593
if sg = [] then raise Not_found else sg
585
594
586
595
let () =
587
-
add_directive "show" (Directive_ident (show_prim show std_out))
596
+
add_directive "show" (Directive_ident (show_prim show std_formatter))
588
597
{
589
598
section = section_env;
590
599
doc = "Print the signatures of components \
···
639
648
}
640
649
641
650
let _ = add_directive "warnings"
642
-
(Directive_string (parse_warnings std_out false))
651
+
(Directive_string (with_error_fmt(fun ppf s -> parse_warnings ppf false s)))
643
652
{
644
653
section = section_options;
645
654
doc = "Enable or disable warnings according to the argument.";
646
655
}
647
656
648
657
let _ = add_directive "warn_error"
649
-
(Directive_string (parse_warnings std_out true))
658
+
(Directive_string (with_error_fmt(fun ppf s -> parse_warnings ppf true s)))
650
659
{
651
660
section = section_options;
652
661
doc = "Treat as errors the warnings enabled by the argument.";
···
716
725
List.iter (print_section ppf) (directive_sections ())
717
726
718
727
let _ = add_directive "help"
719
-
(Directive_none (print_directives std_out))
728
+
(Directive_none (print_directives std_formatter))
720
729
{
721
730
section = section_general;
722
731
doc = "Prints a list of all available directives, with \
+7
typing/btype.ml
+7
typing/btype.ml
+4
typing/btype.mli
+4
typing/btype.mli
+1
-5
typing/env.ml
+1
-5
typing/env.ml
···
2417
2417
| exception Not_found -> ()
2418
2418
2419
2419
let mark_constructor_description_used usage env cstr =
2420
-
let ty_path =
2421
-
match get_desc cstr.cstr_res with
2422
-
| Tconstr(path, _, _) -> path
2423
-
| _ -> assert false
2424
-
in
2420
+
let ty_path = Btype.cstr_type_path cstr in
2425
2421
mark_type_path_used env ty_path;
2426
2422
match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
2427
2423
| mark -> mark usage
+1
-4
typing/typecore.ml
+1
-4
typing/typecore.ml
···
387
387
388
388
(* unification of a type with a Tconstr with freshly created arguments *)
389
389
let unify_head_only ~refine loc env ty constr =
390
-
let path =
391
-
match get_desc constr.cstr_res with
392
-
| Tconstr(p, _, _) -> p
393
-
| _ -> assert false in
390
+
let path = cstr_type_path constr in
394
391
let decl = Env.find_type path !env in
395
392
let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in
396
393
unify_pat_types ~refine loc env ty' ty
+2
-7
typing/typedecl.ml
+2
-7
typing/typedecl.ml
···
1035
1035
typext_params
1036
1036
end;
1037
1037
(* Ensure that constructor's type matches the type being extended *)
1038
-
let cstr_type_path, cstr_type_params =
1039
-
match get_desc cdescr.cstr_res with
1040
-
Tconstr (p, _, _) ->
1041
-
let decl = Env.find_type p env in
1042
-
p, decl.type_params
1043
-
| _ -> assert false
1044
-
in
1038
+
let cstr_type_path = Btype.cstr_type_path cdescr in
1039
+
let cstr_type_params = (Env.find_type cstr_type_path env).type_params in
1045
1040
let cstr_types =
1046
1041
(Btype.newgenty
1047
1042
(Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))