1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
open Mo_def
open Mo_frontend
open Mo_types
open Mo_values
open Mo_interpreter
open Ir_def
open Ir_interpreter
open Ir_passes
open Mo_config
open Printf
module ResolveImport = Resolve_import
type stat_env = Scope.t
type dyn_env = Interpret.scope
type env = stat_env * dyn_env
(* Diagnostics *)
let phase heading name =
if !Flags.verbose then printf "-- %s %s:\n%!" heading name
let print_ce =
Type.ConSet.iter (fun c ->
let eq, params, typ = Type.pps_of_kind (Cons.kind c) in
Format.printf "@[<hv 2>type %s%a %s@ %a@]@."
(Type.string_of_con c)
params ()
eq
typ ()
)
let print_stat_ve =
Type.Env.iter (fun x (t, _, _) ->
let t' = Type.as_immut t in
Format.printf "@[<hv 2>%s %s :@ %a@]@."
(if t == t' then "let" else "var") x
Type.pp_typ t'
)
let print_dyn_ve scope =
Value.Env.iter (fun x d ->
let open Type in
let (t, _, _) = Env.find x scope.Scope.val_env in
let t' = as_immut t in
match normalize t' with
| Obj (Module, fs) ->
Format.printf "@[<hv 2>%s %s : module {...}@]@."
(if t == t' then "let" else "var") x
| _ ->
Format.printf "@[<hv 2>%s %s :@ %a =@ %a@]@."
(if t == t' then "let" else "var") x
Type.pp_typ t'
(Value.pp_def !Flags.print_depth) (t', d)
)
let print_scope senv scope dve =
print_ce scope.Scope.con_env;
print_dyn_ve senv dve
let print_val _senv t v =
Format.printf "@[<hv 2>%a :@ %a@]@."
(Value.pp_val !Flags.print_depth) (t, v)
Type.pp_typ t
(* Dumping *)
let dump_prog flag prog =
if !flag then
Wasm.Sexpr.print 80 (Arrange.prog prog)
let dump_ir flag prog_ir =
if !flag then
Wasm.Sexpr.print 80 (Arrange_ir.prog prog_ir)
(* Parsing *)
type rel_path = string
type parse_result = (Syntax.prog * rel_path) Diag.result
type no_region_parse_fn = string -> parse_result
type parse_fn = Source.region -> no_region_parse_fn
let generic_parse_with mode lexer parser name : _ Diag.result =
phase "Parsing" name;
let open Diag.Syntax in
lexer.Lexing.lex_curr_p <-
{lexer.Lexing.lex_curr_p with Lexing.pos_fname = name};
(* a back door to enable the `prim` syntax, for our test suite *)
let tokenizer, triv_table = Lexer.tokenizer mode lexer in
let* mk_syntax =
try
Parser_lib.triv_table := triv_table;
Parsing.parse mode (!Flags.error_detail) (parser lexer.Lexing.lex_curr_p) tokenizer lexer
with Lexer.Error (at, msg) -> Diag.error at"M0002" "syntax" msg
in
let phrase = mk_syntax name in
Diag.return phrase
let parse_with mode lexer parser name : Syntax.prog Diag.result =
let open Diag.Syntax in
let* prog = generic_parse_with mode lexer parser name in
dump_prog Flags.dump_parse prog;
Diag.return prog
let parse_string' mode name s : parse_result =
let open Diag.Syntax in
let lexer = Lexing.from_string s in
let parse = Parser.Incremental.parse_prog in
let* prog = parse_with mode lexer parse name in
Diag.return (prog, name)
let parse_string = parse_string' Lexer.mode
let parse_file' mode at filename : (Syntax.prog * rel_path) Diag.result =
let ic, messages = Lib.FilePath.open_in filename in
Diag.finally (fun () -> close_in ic) (
let open Diag.Syntax in
let* _ =
Diag.traverse_
(Diag.warn at "M0005" "import")
messages in
let lexer = Lexing.from_channel ic in
let parse = Parser.Incremental.parse_prog in
let* prog = parse_with mode lexer parse filename in
Diag.return (prog, filename)
)
let parse_file = parse_file' Lexer.mode
let parse_verification_file = parse_file' Lexer.mode_verification
(* Import file name resolution *)
type resolve_result = (Syntax.prog * ResolveImport.resolved_imports) Diag.result
let resolve_flags () =
ResolveImport.{
package_urls = !Flags.package_urls;
actor_aliases = !Flags.actor_aliases;
actor_idl_path = !Flags.actor_idl_path;
include_all_libs = !Flags.ai_errors;
}
let resolve_prog (prog, base) : resolve_result =
Diag.map
(fun libs -> (prog, libs))
(ResolveImport.resolve (resolve_flags ()) prog base)
let resolve_progs =
Diag.traverse resolve_prog
(* Printing dependency information *)
let print_deps (file : string) : unit =
let (prog, _) = Diag.run (parse_file Source.no_region file) in
let imports = Diag.run (ResolveImport.collect_imports prog file) in
List.iter (fun (url, path) ->
match path with
| None -> Printf.printf "%s\n" url
| Some path -> Printf.printf "%s %s\n" url path
) imports
(* Checking *)
let async_cap_of_prog prog =
let open Syntax in
let open Source in
match (CompUnit.comp_unit_of_prog false prog).it.body.it with
| ActorClassU _ -> Async_cap.NullCap
| ActorU _ -> Async_cap.initial_cap()
| ModuleU _ -> assert false
| ProgU _ ->
if !Flags.compiled then
Async_cap.NullCap
else
Async_cap.initial_cap()
let infer_prog ?(viper_mode=false) pkg_opt senv async_cap prog : (Type.typ * Scope.scope) Diag.result =
let filename = prog.Source.note.Syntax.filename in
phase "Checking" filename;
let r = Typing.infer_prog ~viper_mode pkg_opt senv async_cap prog in
if !Flags.trace && !Flags.verbose then begin
match r with
| Ok ((_, scope), _) ->
print_ce scope.Scope.con_env;
print_stat_ve scope.Scope.val_env;
dump_prog Flags.dump_tc prog;
| Error _ -> ()
end;
phase "Definedness" filename;
let open Diag.Syntax in
let* t_sscope = r in
let* () = Definedness.check_prog prog in
Diag.return t_sscope
let rec check_progs ?(viper_mode=false) senv progs : Scope.scope Diag.result =
match progs with
| [] -> Diag.return senv
| prog::progs' ->
let open Diag.Syntax in
let async_cap = async_cap_of_prog prog in
let* _t, sscope = infer_prog ~viper_mode senv None async_cap prog in
let senv' = Scope.adjoin senv sscope in
check_progs ~viper_mode senv' progs'
let check_lib senv pkg_opt lib : Scope.scope Diag.result =
let filename = lib.Source.note.Syntax.filename in
phase "Checking" (Filename.basename filename);
let open Diag.Syntax in
let* sscope = Typing.check_lib senv pkg_opt lib in
phase "Definedness" (Filename.basename filename);
let* () = Definedness.check_lib lib in
Diag.return sscope
let lib_of_prog f prog : Syntax.lib =
let lib = CompUnit.comp_unit_of_prog true prog in
{ lib with Source.note = { lib.Source.note with Syntax.filename = f } }
(* Prelude and internals *)
let builtin_error phase what (msgs : Diag.messages) =
Printf.eprintf "%s %s failed\n" phase what;
Diag.print_messages msgs;
exit 1
let check_builtin what src senv0 : Syntax.prog * stat_env =
let lexer = Lexing.from_string src in
let parse = Parser.Incremental.parse_prog in
match parse_with Lexer.mode_priv lexer parse what with
| Error es -> builtin_error "parsing" what es
| Ok (prog, _ws) ->
match infer_prog senv0 None Async_cap.NullCap prog with
| Error es -> builtin_error "checking" what es
| Ok ((_t, sscope), _ws) ->
let senv1 = Scope.adjoin senv0 sscope in
prog, senv1
let prelude, initial_stat_env0 =
check_builtin "prelude" Prelude.prelude Typing.initial_scope
let internals, initial_stat_env =
check_builtin "internals" Prelude.internals initial_stat_env0
(* Stable compatibility *)
let parse_stab_sig s name =
let open Diag.Syntax in
let mode = Lexer.{privileged = false; verification = false} in
let lexer = Lexing.from_string s in
let parse = Parser.Incremental.parse_stab_sig in
let* sig_ = generic_parse_with mode lexer parse name in
Diag.return sig_
let parse_stab_sig_from_file filename : Syntax.stab_sig Diag.result =
let ic = Stdlib.open_in filename in
Diag.finally (fun () -> close_in ic) (
let open Diag.Syntax in
let mode = Lexer.{privileged = false; verification = false} in
let lexer = Lexing.from_channel ic in
let parse = Parser.Incremental.parse_stab_sig in
let* sig_ = generic_parse_with mode lexer parse filename in
Diag.return sig_
)
let stable_compatible pre post : unit Diag.result =
let open Diag.Syntax in
let* p1 = parse_stab_sig_from_file pre in
let* p2 = parse_stab_sig_from_file post in
let* s1 = Typing.check_stab_sig initial_stat_env0 p1 in
let* s2 = Typing.check_stab_sig initial_stat_env0 p2 in
Stability.match_stab_sig s1 s2
let validate_stab_sig s : unit Diag.result =
let open Diag.Syntax in
let name = "stable-types" in
let* p1 = parse_stab_sig s name in
let* p2 = parse_stab_sig s name in
let* s1 = Typing.check_stab_sig initial_stat_env0 p1 in
let* s2 = Typing.check_stab_sig initial_stat_env0 p2 in
Stability.match_stab_sig s1 s2
(* The prim module *)
let prim_name = "prim"
let prim_error phase (msgs : Diag.messages) =
Printf.eprintf "%s prim failed\n" phase;
Diag.print_messages msgs;
exit 1
let check_prim () : Syntax.lib * stat_env =
let lexer = Lexing.from_string (Prelude.prim_module ~timers:!Flags.global_timer) in
let parse = Parser.Incremental.parse_prog in
match parse_with Lexer.mode_priv lexer parse prim_name with
| Error es -> prim_error "parsing" es
| Ok (prog, _ws) ->
let open Syntax in
let open Source in
let senv0 = initial_stat_env in
(* Propagate deprecations *)
let fs = List.map (fun d ->
let trivia = Trivia.find_trivia prog.note.trivia d.at in
let depr = Trivia.deprecated_of_trivia_info trivia in
{vis = Public depr @@ no_region; dec = d; stab = None} @@ d.at) prog.it
in
let body = {it = ModuleU (None, fs); at = no_region; note = empty_typ_note} in
let lib = {
it = { imports = []; body };
at = no_region;
note = { filename = "@prim"; trivia = Trivia.empty_triv_table }
} in
match check_lib senv0 None lib with
| Error es -> prim_error "checking" es
| Ok (sscope, _ws) ->
let senv1 = Scope.adjoin senv0 sscope in
lib, senv1
(* Imported file loading *)
(*
Loading a file (or string) implies lexing, parsing, resolving imports to
libraries, and typechecking.
The resulting prog is typechecked.
The Typing.scope field in load_result is the accumulated scope.
When we load a declaration (i.e from the REPL), we also care about the type
and the newly added scopes, so these are returned separately.
*)
type load_result =
(Syntax.lib list * Syntax.prog list * Scope.scope) Diag.result
type load_decl_result =
(Syntax.lib list * Syntax.prog * Scope.scope * Type.typ * Scope.scope) Diag.result
let chase_imports parsefn senv0 imports : (Syntax.lib list * Scope.scope) Diag.result =
(*
This function loads and type-checkes the files given in `imports`,
including any further dependencies.
The resulting `Syntax.libraries` list is in dependency order. To achieve this,
the function go below does an depth-first traversal of the import DAG.
* To detected illegal cycles, pending is a set of filenames that we started
processing, but did not add yet.
* To avoid duplicates, i.e. load each file at most once, we check the
senv.
* We accumulate the resulting libraries in reverse order, for O(1) appending.
*)
let open ResolveImport.S in
let pending = ref empty in
let senv = ref senv0 in
let libs = ref [] in
let rec go pkg_opt ri = match ri.Source.it with
| Syntax.PrimPath ->
(* a bit of a hack, lib_env should key on resolved_import *)
if Type.Env.mem "@prim" !senv.Scope.lib_env then
Diag.return ()
else
let lib, sscope = check_prim () in
libs := lib :: !libs; (* NB: Conceptually an append *)
senv := Scope.adjoin !senv sscope;
Diag.return ()
| Syntax.Unresolved -> assert false
| Syntax.(LibPath {path = f; package = lib_pkg_opt}) ->
if Type.Env.mem f !senv.Scope.lib_env then
Diag.return ()
else if mem ri.Source.it !pending then
Diag.error
ri.Source.at
"M0003"
"import"
(Printf.sprintf "file %s must not depend on itself" f)
else begin
pending := add ri.Source.it !pending;
let open Diag.Syntax in
let* prog, base = parsefn ri.Source.at f in
let* () = Static.prog prog in
let* more_imports = ResolveImport.resolve (resolve_flags ()) prog base in
let cur_pkg_opt = if lib_pkg_opt <> None then lib_pkg_opt else pkg_opt in
let* () = go_set cur_pkg_opt more_imports in
let lib = lib_of_prog f prog in
let* sscope = check_lib !senv cur_pkg_opt lib in
libs := lib :: !libs; (* NB: Conceptually an append *)
senv := Scope.adjoin !senv sscope;
pending := remove ri.Source.it !pending;
Diag.return ()
end
| Syntax.IDLPath (f, _) ->
let open Diag.Syntax in
let* prog, idl_scope, actor_opt = Idllib.Pipeline.check_file f in
if actor_opt = None then
Diag.error
ri.Source.at
"M0004"
"import"
(Printf.sprintf "file %s does not define a service" f)
else
match Mo_idl.Idl_to_mo.check_prog idl_scope actor_opt with
| exception Idllib.Exception.UnsupportedCandidFeature error_message ->
Stdlib.Error [
Diag.error_message
ri.Source.at
"M0153"
"import"
(Printf.sprintf "file %s uses Candid types without corresponding Motoko type" f);
error_message ]
| actor ->
let sscope = Scope.lib f actor in
senv := Scope.adjoin !senv sscope;
Diag.return ()
and go_set pkg_opt todo = Diag.traverse_ (go pkg_opt) todo
in
Diag.map (fun () -> (List.rev !libs, !senv)) (go_set None imports)
let load_progs ?(viper_mode=false) ?(check_actors=false) parsefn files senv : load_result =
let open Diag.Syntax in
let* parsed = Diag.traverse (parsefn Source.no_region) files in
let* rs = resolve_progs parsed in
let progs' = List.map fst rs in
let libs = List.concat_map snd rs in
let* libs, senv' = chase_imports parsefn senv libs in
let* () = Typing.check_actors ~viper_mode ~check_actors senv' progs' in
let* senv'' = check_progs ~viper_mode senv' progs' in
Diag.return (libs, progs', senv'')
let load_decl parse_one senv : load_decl_result =
let open Diag.Syntax in
let* parsed = parse_one in
let* prog, libs = resolve_prog parsed in
let* libs, senv' = chase_imports parse_file senv libs in
let* t, sscope = infer_prog senv' (Some "<toplevel>") (Async_cap.(AwaitCap top_cap)) prog in
let senv'' = Scope.adjoin senv' sscope in
Diag.return (libs, prog, senv'', t, sscope)
(* Interpretation (Source) *)
let interpret_prog denv prog : (Value.value * Interpret.scope) option =
let open Interpret in
phase "Interpreting" prog.Source.note.Syntax.filename;
let flags = { trace = !Flags.trace; print_depth = !Flags.print_depth } in
let result = Interpret.interpret_prog flags denv prog in
Profiler.process_prog_result result ;
result
let rec interpret_libs denv libs : Interpret.scope =
let open Interpret in
match libs with
| [] -> denv
| lib::libs' ->
phase "Interpreting" (Filename.basename lib.Source.note.Syntax.filename);
let flags = { trace = !Flags.trace; print_depth = !Flags.print_depth } in
let dscope = interpret_lib flags denv lib in
let denv' = adjoin_scope denv dscope in
interpret_libs denv' libs'
let rec interpret_progs denv progs : Interpret.scope option =
match progs with
| [] -> Some denv
| p::ps ->
match interpret_prog denv p with
| Some (_v, dscope) ->
let denv' = Interpret.adjoin_scope denv dscope in
interpret_progs denv' ps
| None -> None
let interpret_files (senv0, denv0) files : (Scope.scope * Interpret.scope) option =
Option.bind
(Diag.flush_messages (load_progs parse_file files senv0))
(fun (libs, progs, senv1) ->
let denv1 = interpret_libs denv0 libs in
match interpret_progs denv1 progs with
| None -> None
| Some denv2 -> Some (senv1, denv2)
)
let run_builtin prog denv : dyn_env =
match interpret_prog denv prog with
| None -> builtin_error "initializing" prog.Source.note.Syntax.filename []
| Some (_v, dscope) ->
Interpret.adjoin_scope denv dscope
let initial_dyn_env = run_builtin internals (run_builtin prelude Interpret.empty_scope)
let initial_env = (initial_stat_env, initial_dyn_env)
(* Only checking *)
type check_result = unit Diag.result
let check_files' parsefn files : check_result =
Diag.map ignore (load_progs parsefn files initial_stat_env)
let check_files files : check_result =
check_files' parse_file files
(* Generate Viper *)
type viper_result = (string * (Source.region -> Source.region option)) Diag.result
let viper_files' parsefn files : viper_result =
let open Diag.Syntax in
let* libs, progs, senv = load_progs ~viper_mode:true parsefn files initial_stat_env in
let* () = Typing.check_actors ~viper_mode:true ~check_actors:true senv progs in
let prog = CompUnit.combine_progs progs in
let u = CompUnit.comp_unit_of_prog false prog in
let reqs = Viper.Common.init_reqs () in
let* v = Viper.Trans.unit reqs (Viper.Prep.prep_unit u) in
let s = Viper.Pretty.prog_mapped "" (Viper.Prelude.prelude reqs) v in
Diag.return s
let viper_files files : viper_result =
viper_files' parse_verification_file files
(* Generate IDL *)
let generate_idl files : Idllib.Syntax.prog Diag.result =
let open Diag.Syntax in
let* libs, progs, senv = load_progs ~check_actors:true parse_file files initial_stat_env in
Diag.return (Mo_idl.Mo_to_idl.prog (progs, senv))
(* Running *)
let run_files files : unit option =
Option.map ignore (interpret_files initial_env files)
(* Interactively *)
let continuing = ref false
let lexer_stdin buf len =
let prompt = if !continuing then " " else "> " in
printf "%s" prompt; flush_all ();
continuing := true;
let rec loop i =
if i = len then i else
let ch = input_char stdin in
Bytes.set buf i ch;
if ch = '\n' then i + 1 else loop (i + 1)
in loop 0
let parse_lexer lexer : parse_result =
let open Lexing in
if lexer.lex_curr_pos >= lexer.lex_buffer_len - 1 then continuing := false;
match parse_with Lexer.mode lexer Parser.Incremental.parse_prog_interactive "stdin" with
| Error es ->
Lexing.flush_input lexer;
(* Reset beginning-of-line, too, to sync consecutive positions. *)
lexer.lex_curr_p <- {lexer.lex_curr_p with pos_bol = 0};
Error es
| Ok (prog, ws) -> Ok ((prog, Filename.current_dir_name), ws)
let is_exp dec = match dec.Source.it with Syntax.ExpD _ -> true | _ -> false
let output_scope (senv, _) t v sscope dscope =
print_scope senv sscope dscope.Interpret.val_env;
if v <> Value.unit then print_val senv t v
let run_stdin lexer (senv, denv) : env option =
match Diag.flush_messages (load_decl (parse_lexer lexer) senv) with
| None ->
if !Flags.verbose then printf "\n";
None
| Some (libs, prog, senv', t, sscope) ->
let denv' = interpret_libs denv libs in
match interpret_prog denv' prog with
| None ->
if !Flags.verbose then printf "\n";
None
| Some (v, dscope) ->
phase "Finished" "stdin";
let denv' = Interpret.adjoin_scope denv dscope in
let env' = (senv', denv') in
(* TBR: hack *)
let t', v' =
if Option.fold ~none:false ~some:is_exp (Lib.List.last_opt prog.Source.it)
then t, v
else Type.unit, Value.unit
in
output_scope env' t' v' sscope dscope;
if !Flags.verbose then printf "\n";
Some env'
let run_stdin_from_file files file : Value.value option =
let open Lib.Option.Syntax in
let* (senv, denv) = interpret_files initial_env files in
let* (libs, prog, senv', t, sscope) =
Diag.flush_messages (load_decl (parse_file Source.no_region file) senv) in
let denv' = interpret_libs denv libs in
let* (v, dscope) = interpret_prog denv' prog in
print_val senv t v;
Some v
let run_files_and_stdin files =
let open Lib.Option.Syntax in
let lexer = Lexing.from_function lexer_stdin in
let* env = interpret_files initial_env files in
let rec loop env = loop (Lib.Option.get (run_stdin lexer env) env) in
try loop env with End_of_file ->
printf "\n%!";
Some ()
(* Desugaring *)
let desugar_unit imports u name : Ir.prog =
phase "Desugaring" name;
let open Lowering.Desugar in
let prog_ir' : Ir.prog = link_declarations
(import_prelude prelude @ import_prelude internals @ imports)
(transform_unit u) in
dump_ir Flags.dump_lowering prog_ir';
if !Flags.check_ir
then Check_ir.check_prog !Flags.verbose "Desugaring" prog_ir';
prog_ir'
(* IR transforms *)
let transform transform_name trans prog name =
phase transform_name name;
let prog_ir' : Ir.prog = trans prog in
dump_ir Flags.dump_lowering prog_ir';
if !Flags.check_ir
then Check_ir.check_prog !Flags.verbose transform_name prog_ir';
prog_ir'
let transform_if transform_name trans flag prog name =
if flag then transform transform_name trans prog name
else prog
let await_lowering =
transform_if "Await Lowering" Await.transform
let async_lowering mode =
transform_if "Async Lowering" Async.transform
let tailcall_optimization =
transform_if "Tailcall optimization" Tailcall.transform
let typ_field_translation =
transform_if "Erase type components" Erase_typ_field.transform
let show_translation =
transform_if "Translate show" Show.transform
let eq_translation =
transform_if "Translate polymorphic equality" Eq.transform
let analyze analysis_name analysis prog name =
phase analysis_name name;
analysis prog;
if !Flags.check_ir
then Check_ir.check_prog !Flags.verbose analysis_name prog
let ir_passes mode prog_ir name =
(* erase typ components from objects *)
let prog_ir = typ_field_translation true prog_ir name in
(* translations that extend the progam and must be done before await/cps conversion *)
let prog_ir = show_translation true prog_ir name in
let prog_ir = eq_translation true prog_ir name in
(* cps conversion and local transformations *)
let prog_ir = await_lowering !Flags.await_lowering prog_ir name in
let prog_ir = async_lowering mode !Flags.async_lowering prog_ir name in
let prog_ir = tailcall_optimization true prog_ir name in
analyze "constness analysis" Const.analyze prog_ir name;
prog_ir
(* Compilation *)
let load_as_rts () =
let rts = match (!Flags.enhanced_orthogonal_persistence, !Flags.sanity, !Flags.gc_strategy) with
| (true, false, Flags.Incremental) -> Rts.wasm_eop_release
| (true, true, Flags.Incremental) -> Rts.wasm_eop_debug
| (false, false, Flags.Copying)
| (false, false, Flags.MarkCompact)
| (false, false, Flags.Generational) -> Rts.wasm_non_incremental_release
| (false, true, Flags.Copying)
| (false, true, Flags.MarkCompact)
| (false, true, Flags.Generational) -> Rts.wasm_non_incremental_debug
| (false, false, Flags.Incremental) -> Rts.wasm_incremental_release
| (false, true, Flags.Incremental) -> Rts.wasm_incremental_debug
| _ -> assert false
in
Wasm_exts.CustomModuleDecode.decode "rts.wasm" (Lazy.force rts)
type compile_result = (Idllib.Syntax.prog * Wasm_exts.CustomModule.extended_module) Diag.result
let invalid_flag message =
builtin_error "compile" (Printf.sprintf "Invalid compiler flag combination: %s" message) []
let adjust_flags () =
if !Flags.enhanced_orthogonal_persistence then
begin
(match !Flags.gc_strategy with
| Flags.Default | Flags.Incremental -> Flags.gc_strategy := Flags.Incremental;
| Flags.Copying -> invalid_flag "--copying-gc is not supported with --enhanced-orthogonal-persistence"
| Flags.MarkCompact -> invalid_flag "--compacting-gc is not supported with --enhanced-orthogonal-persistence"
| Flags.Generational -> invalid_flag "--generational-gc is not supported with --enhanced-orthogonal-persistence");
(if !Flags.rts_stack_pages <> None then invalid_flag "--rts-stack-pages is not supported with --enhanced-orthogonal-persistence");
Flags.rtti := true
end
else
begin
(if !Flags.gc_strategy = Flags.Default then Flags.gc_strategy := Flags.Copying);
(if !Flags.rts_stack_pages = None then Flags.rts_stack_pages := Some Flags.rts_stack_pages_default);
(if !Flags.stabilization_instruction_limit <> Flags.stabilization_instruction_limit_default then
invalid_flag "--stabilization-instruction-limit is only supported with --enhanced-orthogonal-persistence");
(if !Flags.stable_memory_access_limit <> Flags.stable_memory_access_limit_default then
invalid_flag "--stable-memory-access-limit is only supported with --enhanced-orthogonal-persistence")
end
(* This transforms the flat list of libs (some of which are classes)
into a list of imported libs and (compiled) classes *)
let rec compile_libs mode libs : Lowering.Desugar.import_declaration =
let open Source in
let rec go imports = function
| [] -> imports
| l :: libs ->
let { Syntax.body = cub; _ } = l.it in
match cub.it with
| Syntax.ActorClassU _ ->
let wasm = compile_unit_to_wasm mode imports l in
go (imports @ Lowering.Desugar.import_compiled_class l wasm) libs
| _ ->
go (imports @ Lowering.Desugar.import_unit l) libs
in go [] libs
and compile_unit mode do_link imports u : Wasm_exts.CustomModule.extended_module =
let name = u.Source.note.Syntax.filename in
let prog_ir = desugar_unit imports u name in
let prog_ir = ir_passes mode prog_ir name in
phase "Compiling" name;
adjust_flags ();
let rts = if do_link then Some (load_as_rts ()) else None in
if !Flags.enhanced_orthogonal_persistence then
Codegen.Compile_enhanced.compile mode rts prog_ir
else
Codegen.Compile_classical.compile mode rts prog_ir
and compile_unit_to_wasm mode imports (u : Syntax.comp_unit) : string =
let wasm_mod = compile_unit mode true imports u in
let (_source_map, wasm) = Wasm_exts.CustomModuleEncode.encode wasm_mod in
wasm
and compile_progs mode do_link libs progs : Wasm_exts.CustomModule.extended_module =
let imports = compile_libs mode libs in
let prog = CompUnit.combine_progs progs in
let u = CompUnit.comp_unit_of_prog false prog in
compile_unit mode do_link imports u
let compile_files mode do_link files : compile_result =
let open Diag.Syntax in
let* libs, progs, senv = load_progs ~check_actors:true parse_file files initial_stat_env in
let idl = Mo_idl.Mo_to_idl.prog (progs, senv) in
let ext_module = compile_progs mode do_link libs progs in
(* validate any stable type signature *)
let* () =
match Wasm_exts.CustomModule.(ext_module.motoko.stable_types) with
| Some (_, ss) -> validate_stab_sig ss
| _ -> Diag.return ()
in
let* () =
if Wasm_exts.CustomModule.(ext_module.wasm_features) <> []
then Diag.warn Source.no_region "M0191" "compile" (Printf.sprintf "code requires Wasm features %s to execute" (String.concat "," Wasm_exts.CustomModule.(ext_module.wasm_features)))
else Diag.return ()
in
Diag.return (idl, ext_module)
(* Interpretation (IR) *)
(*
This transforms the flat list of libs into a list of imported units,
Unlike, `compile_libs`, classes are imported as IR for interpretation,
not compiled to wasm
*)
let import_libs libs : Lowering.Desugar.import_declaration =
List.concat_map Lowering.Desugar.import_unit libs
let interpret_ir_progs libs progs =
let prog = CompUnit.combine_progs progs in
let name = prog.Source.note.Syntax.filename in
let imports = import_libs libs in
let u = CompUnit.comp_unit_of_prog false prog in
let prog_ir = desugar_unit imports u name in
let prog_ir = ir_passes (!Flags.compile_mode) prog_ir name in
phase "Interpreting" name;
let open Interpret_ir in
let flags = { trace = !Flags.trace; print_depth = !Flags.print_depth } in
interpret_prog flags prog_ir
let interpret_ir_files files =
Option.map
(fun (libs, progs, senv) -> interpret_ir_progs libs progs)
(Diag.flush_messages (load_progs parse_file files initial_stat_env))