Movatterモバイル変換

[0]ホーム
URL:

Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly

 Sign up
Appearance settings
forked fromocaml/ocaml

Commitc102688

Browse files
authored
flambda-backend: Fix soundness bug by using currying information from typing (ocaml#850)
Previously, transl_curried_function in Translcore redetected functioncurrying, which is difficult with locals as modes may make it invalidto merge two lambdas into a single n-ary function.The mode logic here was wrong, leading to a soundness bug. Rather thanfix it (which would continue the duplication of mode-checking betweentyping and transl), the fix here is to add the relevant information toTypedtree, so that Translcore follows the decisions made by typinginstead of redetecting currying on its own.
1 parent6a96b61 commitc102688

File tree

14 files changed

+145
-61
lines changed

14 files changed

+145
-61
lines changed

‎boot/ocamlc

134 Bytes
Binary file not shown.

‎boot/ocamllex

0 Bytes
Binary file not shown.

‎lambda/translcore.ml

Lines changed: 42 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -99,13 +99,10 @@ let transl_alloc_mode alloc_mode =
9999
|Global -> alloc_heap
100100
|Local -> alloc_local
101101

102-
lettransl_value_modemode=
103-
let alloc_mode=Btype.Value_mode.regional_to_global_allocmodein
102+
lettransl_exp_modee=
103+
let alloc_mode=Btype.Value_mode.regional_to_global_alloce.exp_modein
104104
transl_alloc_mode alloc_mode
105105

106-
lettransl_exp_modee= transl_value_mode e.exp_mode
107-
lettransl_pat_modep= transl_value_mode p.pat_mode
108-
109106
lettransl_apply_positionposition=
110107
match positionwith
111108
|Default ->Rc_normal
@@ -176,12 +173,13 @@ let rec push_defaults loc bindings cases partial warnings =
176173
match caseswith
177174
[{c_lhs=pat; c_guard=None;
178175
c_rhs={exp_desc=
179-
Texp_function { arg_label; param; cases; partial; region; warnings }}
176+
Texp_function { arg_label; param; cases; partial;
177+
region; curry; warnings }}
180178
as exp}] ->
181179
let cases= push_defaults exp.exp_loc bindings cases partial warningsin
182180
[{c_lhs=pat; c_guard=None;
183181
c_rhs={expwith exp_desc=Texp_function { arg_label; param; cases;
184-
partial; region; warnings }}}]
182+
partial; region;curry;warnings }}}]
185183
| [{c_lhs=pat; c_guard=None;
186184
c_rhs={exp_attributes=[{Parsetree.attr_name= {txt="#default"};_}];
187185
exp_desc=Texp_let
@@ -352,12 +350,13 @@ and transl_exp0 ~in_new_scope ~scopes e =
352350
let body_kind=Typeopt.value_kind body.exp_env body.exp_typein
353351
transl_let~scopes rec_flag pat_expr_list
354352
body_kind (event_before~scopes body (transl_exp~scopes body))
355-
|Texp_function{arg_label =_; param; cases; partial; region; warnings } ->
353+
|Texp_function { arg_label= _; param; cases; partial;
354+
region; curry; warnings } ->
356355
let scopes=
357356
if in_new_scopethen scopes
358357
else enter_anonymous_function~scopes
359358
in
360-
transl_function~scopes e param cases partial warnings region
359+
transl_function~scopes e param cases partial warnings region curry
361360
|Texp_apply({ exp_desc=Texp_ident(path, _, {val_kind=Val_prim p},
362361
Id_prim pmode);
363362
exp_type= prim_type }as funct, oargs, pos)
@@ -1027,37 +1026,34 @@ and transl_apply ~scopes
10271026

10281027
andtransl_curried_function
10291028
~scopeslocreturn
1030-
repr~mode~regionpartialwarnings (param:Ident.t)cases=
1029+
repr~region~currypartialwarnings (param:Ident.t)cases=
10311030
let max_arity=Lambda.max_arity()in
1032-
letrecloop~scopeslocreturn~arity~mode~regionpartialwarnings
1033-
(param:Ident.t)cases=
1034-
match caseswith
1031+
letrecloop~scopeslocreturn~arity~region~curry
1032+
partialwarnings (param:Ident.t)cases=
1033+
match curry, caseswith
1034+
More_args{partial_mode},
10351035
[{c_lhs=pat; c_guard=None;
10361036
c_rhs={exp_desc=
10371037
Texp_function
10381038
{ arg_label= _; param= param'; cases= cases';
10391039
partial= partial'; region= region';
1040+
curry= curry';
10401041
warnings= warnings' };
1041-
exp_env; exp_type; exp_loc; exp_mode}}]
1042+
exp_env; exp_type; exp_loc}}]
10421043
when arity< max_arity ->
1043-
let arg_mode= transl_pat_mode patin
1044-
let curry_mode= transl_value_mode exp_modein
10451044
(* Lfunctions must have local returns after the first local arg/ret*)
1046-
ifnot (sub_mode mode curry_mode&& sub_mode arg_mode curry_mode)then
1047-
(* Cannot curry here*)
1048-
transl_tupled_function~scopes~arity~mode~region
1049-
loc return repr partial param cases
1050-
elseifParmatch.inactive~partial pat
1045+
ifParmatch.inactive~partial pat
10511046
then
1047+
let partial_mode= transl_alloc_mode partial_modein
10521048
let kind= value_kind pat.pat_env pat.pat_typein
10531049
let return_kind= function_return_value_kind exp_env exp_typein
10541050
let ((fnkind, params, return, region), body)=
10551051
loop~scopes exp_loc return_kind
1056-
~arity:(arity+1)~mode:curry_mode~region:region'
1052+
~arity:(arity+1)~region:region'~curry:curry'
10571053
partial' warnings' param' cases'
10581054
in
10591055
let fnkind=
1060-
matchcurry_mode, fnkindwith
1056+
matchpartial_mode, fnkindwith
10611057
|_,Tupled ->
10621058
(* arity > 1 prevents this*)
10631059
assertfalse
@@ -1080,24 +1076,28 @@ and transl_curried_function
10801076
Warnings.restore prev
10811077
|Partial ->()
10821078
end;
1083-
transl_tupled_function~scopes~arity~mode~region
1079+
transl_tupled_function~scopes~arity~region~curry
10841080
loc return repr partial param cases
10851081
end
1086-
|cases ->
1087-
transl_tupled_function~scopes~arity~mode~region
1082+
|curry,cases ->
1083+
transl_tupled_function~scopes~arity~region~curry
10881084
loc return repr partial param cases
10891085
in
1090-
loop~scopes loc return~arity:1~mode~region partial warnings param cases
1086+
loop~scopes loc return~arity:1~region~curry
1087+
partial warnings param cases
10911088

10921089
andtransl_tupled_function
1093-
~scopes~arity~mode~regionlocreturn
1090+
~scopes~arity~region~currylocreturn
10941091
reprpartial (param:Ident.t)cases=
1095-
match caseswith
1096-
| {c_lhs={pat_desc=Tpat_tuple pl; pat_mode }} :: _
1092+
let partial_mode=
1093+
match currywith
1094+
|More_args{partial_mode}|Final_arg{partial_mode} ->
1095+
transl_alloc_mode partial_mode
1096+
in
1097+
match partial_mode, caseswith
1098+
|Alloc_heap, {c_lhs={pat_desc=Tpat_tuple pl }} :: _
10971099
when!Clflags.native_code
10981100
&& arity=1
1099-
&& is_heap_mode mode
1100-
&& is_heap_mode (transl_value_mode pat_mode)
11011101
&&List.length pl<= (Lambda.max_arity()) ->
11021102
begintry
11031103
let size=List.length plin
@@ -1134,27 +1134,24 @@ and transl_tupled_function
11341134
let region= region||not (may_allocate_in_region body)in
11351135
((Tupled, tparams, return, region), body)
11361136
withMatching.Cannot_flatten ->
1137-
transl_function0~scopes loc~mode~region
1137+
transl_function0~scopes loc~region~partial_mode
11381138
return repr partial param cases
11391139
end
1140-
|_ -> transl_function0~scopes loc~mode~region
1140+
|_ -> transl_function0~scopes loc~region~partial_mode
11411141
return repr partial param cases
11421142

11431143
andtransl_function0
1144-
~scopesloc~mode~regionreturn
1144+
~scopesloc~region~partial_modereturn
11451145
reprpartial (param:Ident.t)cases=
1146-
letarg_mode,kind=
1146+
let kind=
11471147
match caseswith
11481148
|[] ->
11491149
(* With Camlp4, a pattern matching might be empty*)
1150-
alloc_heap,Pgenval
1150+
Pgenval
11511151
|{c_lhs=pat} ::other_cases ->
11521152
(* All the patterns might not share the same types. We must take the
11531153
union of the patterns types*)
1154-
let arg_mode= transl_pat_mode patin
1155-
arg_mode,
11561154
List.fold_left (funk{c_lhs=pat} ->
1157-
assert (transl_pat_mode pat= arg_mode);
11581155
Typeopt.value_kind_union k
11591156
(value_kind pat.pat_env pat.pat_type))
11601157
(value_kind pat.pat_env pat.pat_type) other_cases
@@ -1166,21 +1163,21 @@ and transl_function0
11661163
let region= region||not (may_allocate_in_region body)in
11671164
let nlocal=
11681165
ifnot regionthen1
1169-
elsematchjoin_mode mode arg_modewith
1166+
elsematchpartial_modewith
11701167
|Alloc_local ->1
11711168
|Alloc_heap ->0
11721169
in
11731170
((Curried {nlocal}, [param, kind], return, region), body)
11741171

1175-
andtransl_function~scopeseparamcasespartialwarningsregion=
1172+
andtransl_function~scopeseparamcasespartialwarningsregioncurry=
11761173
let mode= transl_exp_mode ein
11771174
let ((kind, params, return, region), body)=
11781175
event_function~scopes e
11791176
(functionrepr ->
11801177
let pl= push_defaults e.exp_loc[] cases partial warningsin
11811178
let return_kind= function_return_value_kind e.exp_env e.exp_typein
11821179
transl_curried_function~scopes e.exp_loc return_kind
1183-
repr~mode~region partial warnings param pl)
1180+
repr~region~curry partial warnings param pl)
11841181
in
11851182
let attr= default_function_attributein
11861183
let loc= of_location~scopes e.exp_locin
@@ -1497,11 +1494,12 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings =
14971494
let exp= loop (transl_exp~scopes let_.bop_exp) andsin
14981495
let func=
14991496
let return_kind= value_kind case.c_rhs.exp_env case.c_rhs.exp_typein
1497+
let curry=More_args { partial_mode=Btype.Alloc_mode.global }in
15001498
let (kind, params, return, _region), body=
15011499
event_function~scopes case.c_rhs
15021500
(functionrepr ->
15031501
transl_curried_function~scopes case.c_rhs.exp_loc return_kind
1504-
repr~mode:alloc_heap~region:true partial warnings param [case])
1502+
repr~region:true~curry partial warnings param [case])
15051503
in
15061504
let attr= default_function_attributein
15071505
let loc= of_location~scopes case.c_rhs.exp_locin

‎testsuite/tests/typing-local/alloc.heap.reference

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,3 +32,4 @@
3232
verylong: Allocation
3333
manylong: Allocation
3434
optionalarg: Allocation
35+
optionaleta: Allocation

‎testsuite/tests/typing-local/alloc.ml

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -411,6 +411,14 @@ let optionalarg ((f : ?foo:local_ int -> unit -> unit), n) =
411411
let()= f~foo:n()in
412412
()
413413

414+
let[@inline never] optarg ?(n=0)()= n
415+
416+
let[@inline never] optionaleta()=
417+
let[@inline never] use_clos (f : unit -> int)=()in
418+
use_clos (Sys.opaque_identity optarg);
419+
use_clos (Sys.opaque_identity optarg);
420+
()
421+
414422
letrunnamefx=
415423
let prebefore=Gc.allocated_bytes()in
416424
let before=Gc.allocated_bytes()in
@@ -462,7 +470,8 @@ let () =
462470
run"bigstringbint" readbigstringbint();
463471
run"verylong" makeverylong42;
464472
run"manylong" makemanylong100;
465-
run"optionalarg" optionalarg (fun_with_optional_arg,10)
473+
run"optionalarg" optionalarg (fun_with_optional_arg,10);
474+
run"optionaleta" optionaleta()
466475

467476

468477
(* In debug mode, Gc.minor () checks for minor heap->local pointers*)

‎testsuite/tests/typing-local/alloc.stack.reference

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,3 +32,4 @@
3232
verylong: No Allocation
3333
manylong: No Allocation
3434
optionalarg: No Allocation
35+
optionaleta: No Allocation

‎testsuite/tests/typing-local/curry.ml

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -106,3 +106,8 @@ let[@inline never] prim () =
106106
(loc a) (loc b) (loc c) (loc d)
107107

108108
let()= prim()
109+
110+
letcurried (local_x)= { g=fun() ->42 }
111+
let()=
112+
let _= (Sys.opaque_identity curried) (local_ref42)in
113+
Gc.minor()

‎testsuite/tests/typing-local/local.ml

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -551,6 +551,28 @@ Error: This local value escapes its region
551551
Hint: Cannot return local value without an explicit "local_" annotation
552552
|}]
553553

554+
(* Optional argument elimination eta-expands and therefore allocates *)
555+
let no_eta (local_ f : unit -> int) = (f : unit -> int)
556+
[%%expect{|
557+
val no_eta : local_ (unit -> int) -> unit -> int = <fun>
558+
|}]
559+
560+
let eta (local_ f : ?a:bool -> unit -> int) = (f : unit -> int)
561+
[%%expect{|
562+
Line 1, characters 47-48:
563+
1 | let eta (local_ f : ?a:bool -> unit -> int) = (f : unit -> int)
564+
^
565+
Error: This value escapes its region
566+
|}]
567+
568+
let etajoin p (f : ?b:bool -> unit -> int) (local_ g : unit -> int) =
569+
if p then (f : unit -> int) else g
570+
[%%expect{|
571+
val etajoin :
572+
bool -> (?b:bool -> unit -> int) -> local_ (unit -> int) -> unit -> int =
573+
<fun>
574+
|}]
575+
554576
(* Default arguments *)
555577

556578
let foo ?(local_ x) () = x;;

‎typing/btype.ml

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1251,6 +1251,15 @@ module Value_mode = struct
12511251
Alloc_mode.submode_exn r_as_g r_as_l;
12521252
{ r_as_l; r_as_g }
12531253

1254+
letnewvar_below=function
1255+
| { r_as_l=AmodeGlobal;
1256+
r_as_g=AmodeGlobal } ->
1257+
global
1258+
|m ->
1259+
let v= newvar()in
1260+
submode_exn v m;
1261+
v
1262+
12541263
letcheck_constt=
12551264
matchAlloc_mode.check_const t.r_as_lwith
12561265
|None ->None

‎typing/btype.mli

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -391,6 +391,8 @@ module Value_mode : sig
391391

392392
valnewvar :unit ->t
393393

394+
valnewvar_below :t ->t
395+
394396
valcheck_const :t ->constoption
395397

396398
valprint :Format.formatter ->t ->unit

0 commit comments

Comments
 (0)
[8]ページ先頭
©2009-2025 Movatter.jp