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

Commit853c488

Browse files
authored
flambda-backend: Transform tail-recursive functions into recursive continuations (ocaml#893)
1 parent5a977e4 commit853c488

File tree

8 files changed

+78
-7
lines changed

8 files changed

+78
-7
lines changed

‎lambda/lambda.ml

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -386,6 +386,11 @@ type check_attribute =
386386
|Assertofproperty
387387
|Assumeofproperty
388388

389+
typeloop_attribute=
390+
|Always_loop(* [@loop] or [@loop always]*)
391+
|Never_loop(* [@loop never]*)
392+
|Default_loop(* no [@loop] attribute*)
393+
389394
typefunction_kind=Curriedof {nlocal:int} |Tupled
390395

391396
typelet_kind=Strict |Alias |StrictOpt
@@ -407,6 +412,7 @@ type function_attribute = {
407412
local:local_attribute;
408413
check :check_attribute;
409414
poll:poll_attribute;
415+
loop:loop_attribute;
410416
is_a_functor:bool;
411417
stub:bool;
412418
}
@@ -540,6 +546,7 @@ let default_function_attribute = {
540546
local=Default_local;
541547
check=Default_check ;
542548
poll=Default_poll;
549+
loop=Default_loop;
543550
is_a_functor=false;
544551
stub=false;
545552
}

‎lambda/lambda.mli

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -299,6 +299,11 @@ type poll_attribute =
299299
|Error_poll(* [@poll error]*)
300300
|Default_poll(* no [@poll] attribute*)
301301

302+
typeloop_attribute=
303+
|Always_loop(* [@loop] or [@loop always]*)
304+
|Never_loop(* [@loop never]*)
305+
|Default_loop(* no [@loop] attribute*)
306+
302307
typefunction_kind=Curriedof {nlocal:int} |Tupled
303308
(* [nlocal] determines how many arguments may be partially applied
304309
before the resulting closure must be locally allocated.
@@ -327,6 +332,7 @@ type function_attribute = {
327332
local:local_attribute;
328333
check :check_attribute;
329334
poll:poll_attribute;
335+
loop:loop_attribute;
330336
is_a_functor:bool;
331337
stub:bool;
332338
}

‎lambda/printlambda.ml

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -564,7 +564,7 @@ let check_attribute ppf check =
564564
|Assumep -> fprintf ppf"assume %s@" (check_property p)
565565

566566
letfunction_attributeppf
567-
{ inline; specialise; check; local; is_a_functor; stub; poll }=
567+
{ inline; specialise; check; local; is_a_functor; stub; poll; loop }=
568568
if is_a_functorthen
569569
fprintf ppf"is_a_functor@";
570570
if stubthen
@@ -590,7 +590,12 @@ let function_attribute ppf
590590
|Default_poll ->()
591591
|Error_poll -> fprintf ppf"error_poll@"
592592
end;
593-
check_attribute ppf check
593+
check_attribute ppf check;
594+
beginmatch loopwith
595+
|Default_loop ->()
596+
|Always_loop -> fprintf ppf"always_loop@"
597+
|Never_loop -> fprintf ppf"never_loop@"
598+
end
594599

595600
letapply_tailcall_attributeppf=function
596601
|Default_tailcall ->()

‎lambda/translattribute.ml

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,10 @@ let is_poll_attribute = function
4747
|{txt=("poll")} ->true
4848
|_ ->false
4949

50+
letis_loop_attribute=function
51+
|{txt=("loop"|"ocaml.loop")} ->true
52+
|_ ->false
53+
5054
letfind_attributepattributes=
5155
let inline_attribute, other_attributes=
5256
List.partition (funa -> p a.Parsetree.attr_name) attributes
@@ -230,6 +234,19 @@ let parse_poll_attribute attr =
230234
]
231235
payload
232236

237+
letparse_loop_attributeattr=
238+
match attrwith
239+
|None ->Default_loop
240+
|Some{Parsetree.attr_name ={txt; loc};attr_payload =payload} ->
241+
parse_id_payload txt loc
242+
~default:Default_loop
243+
~empty:Always_loop
244+
[
245+
"never",Never_loop;
246+
"always",Always_loop;
247+
]
248+
payload
249+
233250
letget_inline_attributel=
234251
let attr, _= find_attribute is_inline_attribute lin
235252
parse_inline_attribute attr
@@ -257,6 +274,10 @@ let get_poll_attribute l =
257274
let attr, _= find_attribute is_poll_attribute lin
258275
parse_poll_attribute attr
259276

277+
letget_loop_attributel=
278+
let attr, _= find_attribute is_loop_attribute lin
279+
parse_loop_attribute attr
280+
260281
letcheck_local_inlinelocattr=
261282
match attr.local, attr.inlinewith
262283
|Always_local, (Always_inline |Available_inline |Unroll_) ->
@@ -388,6 +409,23 @@ let add_poll_attribute expr loc attributes =
388409
(Warnings.Misplaced_attribute"error_poll");
389410
expr
390411

412+
letadd_loop_attributeexprlocattributes=
413+
match expr, get_loop_attribute attributeswith
414+
|expr,Default_loop -> expr
415+
|Lfunction({attr ={stub =false }asattr }asfunct),loop ->
416+
beginmatch attr.loopwith
417+
|Default_loop ->()
418+
|Always_loop|Never_loop ->
419+
Location.prerr_warning loc
420+
(Warnings.Duplicated_attribute"loop")
421+
end;
422+
let attr= { attrwith loop }in
423+
Lfunction { functwith attr= attr }
424+
|expr, (Always_loop |Never_loop) ->
425+
Location.prerr_warning loc
426+
(Warnings.Misplaced_attribute"loop");
427+
expr
428+
391429
(* Get the [@inlined] attribute payload (or default if not present).
392430
It also returns the expression without this attribute. This is
393431
used to ensure that this attribute is not misplaced: If it
@@ -504,6 +542,9 @@ let add_function_attributes lam loc attr =
504542
let lam=
505543
add_check_attribute lam loc attr
506544
in
545+
let lam=
546+
add_loop_attribute lam loc attr
547+
in
507548
let lam=
508549
(* last because poll overrides inline and local*)
509550
add_poll_attribute lam loc attr

‎lambda/translattribute.mli

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,16 @@ val get_local_attribute
5353
:Parsetree.attributes
5454
->Lambda.local_attribute
5555

56+
val add_loop_attribute
57+
:Lambda.lambda
58+
->Location.t
59+
->Parsetree.attributes
60+
->Lambda.lambda
61+
62+
val get_loop_attribute
63+
:Parsetree.attributes
64+
->Lambda.loop_attribute
65+
5666
val get_and_remove_inlined_attribute
5767
:Typedtree.expression
5868
->Lambda.inlined_attribute*Typedtree.expression

‎lambda/translcore.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -818,6 +818,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
818818
specialise=Always_specialise;
819819
local=Never_local;
820820
check=Default_check;
821+
loop=Never_loop;
821822
is_a_functor=false;
822823
stub=false;
823824
poll=Default_poll;

‎lambda/translmod.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -548,6 +548,7 @@ let rec compile_functor ~scopes mexp coercion root_path loc =
548548
local=Default_local;
549549
poll=Default_poll;
550550
check=Default_check;
551+
loop=Never_loop;
551552
is_a_functor=true;
552553
stub=false;
553554
};

‎testsuite/tests/functors/functors.compilers.reference

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2,14 +2,14 @@
22
(let
33
(O =
44
(module-defn(O) Functors functors.ml(12):184-279
5-
(function X is_a_functor always_inline
5+
(function X is_a_functor always_inline never_loop
66
(let
77
(cow = (function x[int] : int (apply (field 0 X) x))
88
sheep = (function x[int] : int (+ 1 (apply cow x))))
99
(makeblock 0 cow sheep))))
1010
F =
1111
(module-defn(F) Functors functors.ml(17):281-392
12-
(function X Y is_a_functor always_inline
12+
(function X Y is_a_functor always_inline never_loop
1313
(let
1414
(cow =
1515
(function x[int] : int
@@ -18,7 +18,7 @@
1818
(makeblock 0 cow sheep))))
1919
F1 =
2020
(module-defn(F1) Functors functors.ml(31):516-632
21-
(function X Y is_a_functor always_inline
21+
(function X Y is_a_functor always_inline never_loop
2222
(let
2323
(cow =
2424
(function x[int] : int
@@ -27,7 +27,7 @@
2727
(makeblock 0 sheep))))
2828
F2 =
2929
(module-defn(F2) Functors functors.ml(36):634-784
30-
(function X Y is_a_functor always_inline
30+
(function X Y is_a_functor always_inline never_loop
3131
(let
3232
(X =a (makeblock 0 (field 1 X))
3333
Y =a (makeblock 0 (field 1 Y))
@@ -41,7 +41,7 @@
4141
(let
4242
(F =
4343
(module-defn(F) Functors.M functors.ml(44):849-966
44-
(function X Y is_a_functor always_inline
44+
(function X Y is_a_functor always_inline never_loop
4545
(let
4646
(cow =
4747
(function x[int] : int

0 commit comments

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