Simon Génier pushed to branch gambit-compile-pervasives at Stefan / Typer

Commits: cff22dd5 by Simon Génier at 2022-09-21T14:05:55-04:00 Compile calls with no arguments to just the function.

- - - - -

3 changed files:

- src/elab.ml - src/gambit.ml - typer.ml

Changes:

===================================== src/elab.ml ===================================== @@ -2221,3 +2221,20 @@ let process_file ectx' with | Sys_error _ -> Log.user_error {|file %s does not exist.|} path + +class lexp_compiler channel = object + inherit Backend.compiler + + method process_decls ldecls = + let f = formatter_of_out_channel channel in + List.iter (fprintf f "%a@." Lexp.pp_print_decl) ldecls +end + +class elexp_compiler lctx channel = object + inherit Backend.compiler + + method process_decls ldecls = + let f = formatter_of_out_channel channel in + let _, eldecls = Opslexp.clean_decls lctx ldecls in + List.iter (fprintf f "%a@." Elexp.pp_print_decl) eldecls +end

===================================== src/gambit.ml ===================================== @@ -228,6 +228,9 @@ let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = Scm.List [Scm.Symbol name]; scheme_of_expr sctx' body]

+ | Elexp.Call (head, []) + -> scheme_of_expr sctx head + | Elexp.Call (head, tail) -> let scm_head = scheme_of_expr sctx head in let scm_tail = List.map (scheme_of_expr sctx) tail in @@ -254,66 +257,40 @@ let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = in make_curried_lambda vars vector_expr

+ | Elexp.Case (_, target, branches, None) when SMap.cardinal branches = 1 + -> let _, branch = SMap.choose branches in + uncall_by_namify + sctx target (fun scm_target -> + scheme_of_branch sctx scm_target branch) + | Elexp.Case (_, target, branches, default_branch) - -> let target_name = - match target with - | Elexp.Var _ -> scheme_of_expr sctx target - | _ -> Scm.Symbol (gensym "target") - in - let scm_default_branch = - match default_branch with - | None -> [] - | Some (name, body) - -> let sctx, name = ScmContext.intro sctx name in - (* (else => (lambda (name) body)) *) - [Scm.List [Scm.else'; - Scm.double_right_arrow; - Scm.List [Scm.lambda; - Scm.List [Scm.Symbol name]; - scheme_of_expr sctx body]]] - in - let add_branch cons_name (_, field_names, branch_body) scm_branches = - let make_binding (sctx, bindings, i) (location, name) = - match name with - | Some "_" -> sctx, bindings, Z.succ i - | _ - -> let sctx, name = ScmContext.intro sctx (location, name) in - let binding = Scm.List [Scm.Symbol name; - Scm.List [Scm.prim_vector_ref; - target_name; - Scm.Integer i]] - in - sctx, binding :: bindings, Z.succ i - in - let sctx, bindings, _ = List.fold_left make_binding (sctx, [], Z.one) field_names in - let scm_branch = - Scm.List [Scm.List [Scm.symbol cons_name]; - if Int.equal (List.length bindings) 0 - then scheme_of_expr sctx branch_body - else - Scm.List [Scm.let'; - Scm.List (List.rev bindings); - scheme_of_expr sctx branch_body]] - in - scm_branch :: scm_branches - in - let scm_branches = - List.rev_append (SMap.fold add_branch branches []) scm_default_branch - in - let scm_case = - Scm.List (Scm.case - :: Scm.List [Scm.prim_vector_ref; - target_name; - Scm.Integer Z.zero] - :: scm_branches) - in - (match target with - | Elexp.Var _ -> scm_case - | _ - -> Scm.List [Scm.let'; - Scm.List [Scm.List [target_name; - scheme_of_expr sctx target]]; - scm_case]) + -> uncall_by_namify + sctx target (fun scm_target -> + let scm_default_branch = + match default_branch with + | None -> [] + | Some (name, body) + -> let sctx, name = ScmContext.intro sctx name in + (* (else => (lambda (name) body)) *) + [Scm.List [Scm.else'; + Scm.double_right_arrow; + Scm.List [Scm.lambda; + Scm.List [Scm.Symbol name]; + scheme_of_expr sctx body]]] + in + let add_branch cons_name branch scm_branches = + Scm.List [Scm.List [Scm.symbol cons_name]; + scheme_of_branch sctx scm_target branch] + :: scm_branches + in + let scm_branches = + List.rev_append (SMap.fold add_branch branches []) scm_default_branch + in + Scm.List (Scm.case + :: Scm.List [Scm.prim_vector_ref; + scm_target; + Scm.Integer Z.zero] + :: scm_branches))

| Elexp.Type (expr) -> diagnostic_error @@ -327,6 +304,39 @@ let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = ~context:[Elexp.display_context ~label:"elexp" elexp] __POS__ "[gambit] unsupported elexp"

+and scheme_of_branch sctx (target : Scm.t) (_, field_names, branch_body) = + let make_binding (sctx, bindings, i) (location, name) = + match name with + | None -> sctx, bindings, Z.succ i + | Some _ + -> let sctx, name = ScmContext.intro sctx (location, name) in + let binding = Scm.List [Scm.Symbol name; + Scm.List [Scm.prim_vector_ref; + target; + Scm.Integer i]] + in + sctx, binding :: bindings, Z.succ i + in + let sctx, bindings, _ = List.fold_left make_binding (sctx, [], Z.one) field_names in + if Int.equal (List.length bindings) 0 + then scheme_of_expr sctx branch_body + else + Scm.List [Scm.let'; + Scm.List (List.rev bindings); + scheme_of_expr sctx branch_body] + +(** Wraps the body in a let-binding to avoid repeated evaluation because of + call-by-name, but only if necessary. *) +and uncall_by_namify + (sctx : ScmContext.t) (expr : Elexp.t) (make_body : Scm.t -> Scm.t) + : Scm.t = + let scm_expr = scheme_of_expr sctx expr in + match expr with + | Elexp.Var _ | Elexp.Builtin _ -> make_body scm_expr + | _ -> + let name = Scm.Symbol (gensym "") in + Scm.List [Scm.let'; Scm.List [Scm.List [name; scm_expr]]; make_body name] + class inferior script_path = let _ = trace_info __POS__ "Starting inferior Gambit" in let down_reader, down_writer = Unix.pipe ~cloexec:true () in

===================================== typer.ml ===================================== @@ -33,6 +33,21 @@ let add_input_file, list_input_files =

let preload_pervasives : bool ref = ref true

+type target = + | Gambit + | Lexp + | Elexp + +let arg_target = ref Lexp + +let set_target name = + arg_target := + match name with + | "gambit" -> Gambit + | "lexp" -> Lexp + | "elexp" -> Elexp + | _ -> failwith "invalid target" + let generic_arg_spec = [("--verbosity", Arg.String (fun s -> Log.Diagnostics.Config.level := Log.Level.parse s), @@ -58,6 +73,9 @@ let compile_arg_spec = ("--no-pervasives", Arg.Clear preload_pervasives, "Do not load the pervasives.") + :: ("--target", + Arg.Symbol (["gambit"; "lexp"; "elexp"], set_target), + "Select the target, i.e. which kind of code to generate.") :: generic_arg_spec

let parse_args spec argv usage = @@ -78,17 +96,29 @@ let compile_main argv = Elab.load_special_forms Debruijn.empty_elab_context end in - let backend = new Gambit.gambit_compiler (ectx_to_lctx ectx) stdout in

- let _ = - Fun.protect - ~finally:(fun () -> - backend#stop; - Log.Diagnostics.print_log ()) - (fun () - -> List.fold_left (Elab.process_file backend) ectx (list_input_files ())) + let compile backend = + let _ = + Fun.protect + ~finally:Log.Diagnostics.print_log + (fun () + -> List.fold_left + (Elab.process_file backend) + ectx + (list_input_files ())) + in + () in - () + + let lctx = ectx_to_lctx ectx in + match !arg_target with + | Gambit + -> let backend = new Gambit.gambit_compiler lctx stdout in + Fun.protect + ~finally:(fun () -> backend#stop) + (fun () -> compile (backend :> Backend.compiler)) + | Lexp -> compile (new Elab.lexp_compiler stdout) + | Elexp -> compile (new Elab.elexp_compiler lctx stdout)

let repl_main argv = let usage = Sys.executable_name ^ " repl [options] [<file>] …" in @@ -151,4 +181,6 @@ let main () = -> eprintf {|unknown command "%s"|} command; exit 1)

-let () = main () +let () = + try main () with + | Arg.Bad (message) -> print_string message

View it on GitLab: https://gitlab.com/monnier/typer/-/commit/cff22dd57eccaf291fed2b3709845004f3...