flan/bin/main.ml

(* flan — milestone 2 driver. *)

let with_errors path f =
  try f () with
  | Flan.Loc.Error (loc, msg) ->
    Printf.eprintf "%s: %s\n" (Flan.Loc.to_string loc) msg;
    ignore path;
    exit 1

let summarise (d : Flan.Ast.decl) =
  let open Flan.Ast in
  match d.d with
  | Package n -> Printf.sprintf "package %s" n
  | Import (a, p) -> Printf.sprintf "import %s %S" a p
  | Defalias (n, _) -> Printf.sprintf "defalias %s" n
  | Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
  | Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs)
  | Defvar (n, _, _) -> Printf.sprintf "defvar %s" n
  | Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
  | Declare (fn, csym) ->
    Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
      csym
  | Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
  | Defn fn ->
    Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
      fn.name (List.length fn.params)
      (match fn.ret with None -> "Unit" | Some _ -> "explicit")
      (List.length fn.fbody)

(* Every path past [parse] goes through [Load]: an import is resolved into the
   declarations it stands for, and the package's C shim and linker arguments
   come back with them. *)
let load path : Flan.Load.t =
  Flan.Load.program ~file:path (Flan.Parse.program (Flan.Reader.read_file path))

let checked path = Flan.Check.program (load path).decls

(* Bounds checks are on unless a build asks for them off — the release
   decision, not the optimisation level (NEXT.md, Bounds checks). *)
let no_checks_flag = "--no-bounds-checks"

(* A dev build is the one a REPL can attach to: every call goes through a cell
   so a redefinition can be installed, and the cells and globals are exported
   so a loaded module can reach them (NEXT.md, the dev loop). *)
let dev_flag = "--dev"

let flags = [ no_checks_flag; dev_flag ]

let () =
  match Array.to_list Sys.argv with
  | _ :: "read" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           Flan.Reader.read_file path
           |> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
      files
  | _ :: "parse" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           Flan.Reader.read_file path
           |> Flan.Parse.program
           |> List.iter (fun d -> print_endline (summarise d))))
      files
  | _ :: "check" :: files when files <> [] ->
    List.iter
      (fun path ->
         with_errors path (fun () ->
           let p = checked path in
           List.iter
             (fun (g : Flan.Tast.global) ->
                Printf.printf "%s %s %s\n"
                  (if g.gconst then "defconst" else "defvar")
                  g.gname (Flan.Types.to_string g.gty))
             p.globals;
           List.iter
             (fun (f : Flan.Tast.fn) ->
                Printf.printf "defn %s : (Fn [%s] %s)  %d slots\n" f.name
                  (String.concat " "
                     (List.map Flan.Types.to_string f.params))
                  (Flan.Types.to_string f.ret) (Array.length f.slots))
             p.fns))
      files
  | _ :: "emit" :: args when List.exists (fun a -> not (List.mem a flags)) args ->
    let checks = not (List.mem no_checks_flag args) in
    let dev = List.mem dev_flag args in
    let files = List.filter (fun a -> not (List.mem a flags)) args in
    List.iter
      (fun path ->
         with_errors path (fun () ->
           checked path |> Flan.Emit.program ~checks ~dev |> print_string))
      files
  | _ :: "build" :: path :: rest ->
    let checks = not (List.mem no_checks_flag rest) in
    let dev = List.mem dev_flag rest in
    let out =
      match List.filter (fun a -> not (List.mem a flags)) rest with
      | [ "-o"; o ] -> o
      | [] -> Filename.remove_extension (Filename.basename path)
      | _ ->
        prerr_endline
          "usage: flan build <file.flan> [-o out] [--no-bounds-checks] [--dev]";
        exit 2
    in
    with_errors path (fun () ->
      let l = load path in
      let p = Flan.Check.program l.decls in
      ignore (Flan.Build.executable
                ~opts:{ Flan.Build.default with checks; dev }
                ~csrcs:l.csrcs ~lflags:l.lflags p ~out))
  (* One redefinition, built the way an editor will ask for it: a session over
     the program the process was built from, and a file of the forms that
     changed. The session works out which names are new and whether the change
     is one a running process can be told at all — neither of which a command
     given only a list of function names could. *)
  | _ :: "reload" :: prog :: forms :: rest ->
    let out =
      match rest with
      | [ "-o"; o ] -> o
      | [] -> Filename.remove_extension (Filename.basename forms) ^ ".so"
      | _ ->
        prerr_endline "usage: flan reload <program.flan> <forms.flan> [-o out.so]";
        exit 2
    in
    with_errors forms (fun () ->
      let t, _ = Flan.Session.create ~file:prog in
      let src = In_channel.with_open_bin forms In_channel.input_all in
      let c = Flan.Session.eval ~origin:forms t src in
      let opts = { Flan.Build.default with dev = true } in
      let timing = Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out () in
      Printf.eprintf "%s  %s  llc %.1fms  ld %.1fms\n" out
        (String.concat " " c.Flan.Session.fns) timing.Flan.Build.llc_ms
        timing.Flan.Build.link_ms)
  | _ :: "run" :: path :: args ->
    with_errors path (fun () ->
      let exe =
        Filename.concat (Filename.get_temp_dir_name ())
          (Printf.sprintf "flan-run-%d" (Unix.getpid ()))
      in
      let l = load path in
      let p = Flan.Check.program l.decls in
      ignore (Flan.Build.executable ~csrcs:l.csrcs ~lflags:l.lflags p ~out:exe);
      let code =
        Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
      in
      (try Sys.remove exe with Sys_error _ -> ());
      exit code)
  | _ ->
    prerr_endline
      "usage: flan (read|parse|check|emit) <file.flan>...\n\
      \       flan build <file.flan> [-o out] [--no-bounds-checks] [--dev]\n\
      \       flan run <file.flan> [args...]\n\
      \       flan reload <program.flan> <forms.flan> [-o out.so]";
    exit 2