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

Commits: 6a087502 by Simon Génier at 2022-09-22T03:25:33-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 ===================================== @@ -18,7 +18,7 @@ * You should have received a copy of the GNU General Public License along * with this program. If not, see http://www.gnu.org/licenses/. *)

-open Printf +open Format

open Debruijn open Elexp @@ -139,29 +139,52 @@ let gensym : string -> string = Scm.escape_symbol name

module ScmContext = struct + type entry = + | Var of string * string option + | Poison of string option + (* Maps Debruijn indices to Scheme variable names. *) - type t = string Myers.myers + type t = entry Myers.myers

let nil : t = Myers.nil

let of_lctx (lctx : lexp_context) : t = - let f ((_, name), _, _) = Option.get name in + let f ((_, name), _, _) = + match name with + | Some name -> Var (name, Some name) + | None -> Poison (name) + in Myers.map f lctx

let intro (sctx : t) (_, name : vname) : t * string = - let name = + let scm_name = match name with | Some name -> name - | None -> gensym "g" + | None -> gensym "" in - (Myers.cons name sctx, name) + (Myers.cons (Var (scm_name, name)) sctx, scm_name) + + (** Introduces a variable, that must not be used. *) + let poison (sctx : t) (_, name : vname) : t = + Myers.cons (Poison (name)) sctx

let intro_binding (sctx : t) (name, elexp : vname * elexp) = let sctx, name = intro sctx name in (sctx, (name, elexp))

- let lookup (sctx : t) (index : int) : string option = - Myers.nth_opt index sctx + let lookup (sctx : t) ((_, expected_name), index : vref) : string = + match Myers.nth index sctx with + | Var (scm_name, actual_name) when expected_name = actual_name -> scm_name + | Var (_, actual_name) -> + trace_fatal + __POS__ "Debruijn strikes again (expected = “%a”, actual = “%a”)" + (pp_print_option pp_print_string) expected_name + (pp_print_option pp_print_string) actual_name + | Poison (actual_name) -> + trace_fatal + __POS__ "Attempted to reference deleted variable (expected = “%a”, actual = “%a”)" + (pp_print_option pp_print_string) expected_name + (pp_print_option pp_print_string) actual_name end

let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = @@ -202,11 +225,8 @@ let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = location "builtin is not supported on the Gambit backend: %s" name; Scm.Symbol "error"

- | Elexp.Var (_, index) -> - begin match ScmContext.lookup sctx index with - | None -> Scm.Symbol "TODO" - | Some name -> Scm.Symbol name - end + | Elexp.Var (vref) -> + Scm.Symbol (ScmContext.lookup sctx vref)

| Elexp.Let (_, bindings, body) -> if List.length bindings = 0 @@ -228,6 +248,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 +277,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 +324,42 @@ 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) (_, name as vname) = + let sctx', bindings' = + match name with + | None -> + ScmContext.poison sctx vname, bindings + | Some _ -> + let sctx', scm_name = ScmContext.intro sctx vname in + let binding = + Scm.List [Scm.Symbol scm_name; + Scm.List [Scm.prim_vector_ref; target; Scm.Integer i]] + in + sctx', binding :: bindings + in + sctx', 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 @@ -414,7 +447,13 @@ let scheme_of_decl | Elexp.Type _ -> None | Elexp.Builtin (_, ("Eq" | "Int" | "IO" | "String" | "Sexp" | "TypeLevel")) -> None | _ -> - Some (Scm.List ([Scm.define; Scm.Symbol name; scheme_of_expr sctx elexp])) + let scm_expr = scheme_of_expr sctx elexp in + begin match scm_expr with + | Scm.List (Scm.Symbol ("lambda") :: Scm.List args :: body) -> + Some + (Scm.List (Scm.define :: Scm.List (Scm.Symbol (name) :: args) :: body)) + | _ -> Some (Scm.List ([Scm.define; Scm.Symbol (name); scm_expr])) + end

class gambit_compiler lctx output = object inherit Backend.compiler

===================================== 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/6a0875023133ca2515c1c3c45aa3c47291...