flan/lib/expand.ml

(** Macro expansion: the pass between the reader and [Parse].

    There is no interpreter and there is not going to be one (docs/BUILT.md, "Why
    there is no interpreter"), so running a macro at compile time means
    compiling it and loading it into this process. Every piece of that is
    already built and measured — [Emit.macro_thunk], [Build.macro_module],
    [Dynload] — and this file is the two halves nobody had written: the image
    format the two sides share, and the walk that finds macro calls and
    replaces them.

    Expansion runs over [Form], before [Parse]. Not over [Ast]: [Parse] refuses
    [defmacro] outright and there is no [Ast.Defmacro], so an Ast-level pass
    would have nothing to work with. That refusal is the ordering. It is also
    Clojure's ordering, and it is why a macro expanding to a special form is
    ordinary here rather than a special case. *)

(* ── The image format ──────────────────────────────────────────────
   A Form is { i32 tag, [2 x i64] payload }: 24 bytes, align 8, payload at
   offset 8. Those three numbers are the whole agreement between this file and
   the compiled macro, and they are not taken on trust — test_acceptance.ml's
   "Form's image format" asks LLVM for each of them through the same ptrtoint
   oracle the DWARF offsets go through. Change the prelude's defdata and that
   test says which number moved.

   The tag is the case's position in the prelude's (defdata Form ...), which
   is why that list is a layout contract and says so. *)

let form_size = 24
let payload = 8

(* A string and a slice are both %slice = { ptr, i64 }: two words at the start
   of the payload. Every case of Form holds one member, so there is no third
   offset anywhere below. *)
let ptr_off = payload
let len_off = payload + 8

type tag =
  | TSym | TKw | TInt | TFloat | TStr | TByte | TList | TVec | TMap

let tag_int = function
  | TSym -> 0l | TKw -> 1l | TInt -> 2l | TFloat -> 3l | TStr -> 4l
  | TByte -> 5l | TList -> 6l | TVec -> 7l | TMap -> 8l

let tag_of_int = function
  | 0l -> TSym | 1l -> TKw | 2l -> TInt | 3l -> TFloat | 4l -> TStr
  | 5l -> TByte | 6l -> TList | 7l -> TVec | 8l -> TMap
  | n ->
    failwith
      (Printf.sprintf
         "a macro returned a Form with tag %ld, and Form has nine cases. The \
          prelude's (defdata Form ...) and lib/expand.ml's tag list are one \
          contract and have come apart"
         n)

(* ── Writing a Form into memory a macro can read ───────────────────
   OCaml cannot address raw memory, so this goes through the poke family in
   dynload_stubs.c, one field at a time. Everything allocated here is owned by
   [Dynload] and released together after the call. *)

(* ── Which node a pointer belongs to ───────────────────────────────
   A [Form] on the wire has no [loc] field and is not getting one. What it does
   have, for every case but the three that fit inside the payload, is a
   pointer: a string's bytes, or a bracket's children. This compiler allocated
   that memory, so the address names the node it was written for — and when a
   macro splices one of its arguments through untouched, the 24-byte struct is
   copied but the pointer inside it is not. The address is the part that
   survives the trip, so it is what a form coming back out is recognised by.

   That is SBCL's [*source-paths*] (src/compiler/ir1tran.lisp), an EQ table
   from the conses of a form to where they were read, which still answers after
   a macro splices those same conses into its expansion. The address stands in
   for [eq] because across a C ABI nothing else can: two sides that share no
   heap share no notion of identity but the pointer.

   One table per call, made in [call] and gone when it returns. A macro that
   keeps a form from one call and answers with it in another gets a miss, and a
   miss is the harmless direction. *)

type sites = (Dynload.addr, Loc.t) Hashtbl.t

(* ── A wide literal's round trip ───────────────────────────────────
   A macro's [Form] has one integer case, so a literal at or above 2^63 crosses
   as its bit pattern in [Int]'s payload. What marks it as wide is the second
   payload word, which [Int] does not use and which a macro that passes the
   form through copies along with the rest of its 24 bytes: [write] puts a
   token there naming the literal's spelling in this table, and [unmarshal]
   turns a node carrying one back into the [UInt] that went in. An [Int] the
   macro built itself has no token, and is the [Int] it says it is. One table
   per call, as [sites] is. *)
let wide_mark = 0x5749444500000000L

let wides : (int64, int64 * string) Hashtbl.t ref = ref (Hashtbl.create 1)

(* Into an existing 24 bytes, which is what an argument array needs: the macro
   takes a [Form] slice, and a slice is contiguous elements and not an array of
   pointers — so this writes *into* memory the caller took, and every caller
   here takes it as part of an array. *)
let rec write (sites : sites) p (f : Form.t) =
  let tag t = Dynload.poke_i32 p 0 (tag_int t) in
  let note b = Hashtbl.replace sites b f.Form.loc in
  let str t s =
    tag t;
    let n = String.length s in
    (* A zero-length string still gets a pointer, because a slice with a null
       base is not the same value as one with a live base and a zero length --
       the difference shows the day something concatenates onto it. It also
       keeps every node's key distinct, which the table above depends on. *)
    let b = Dynload.take (max n 1) in
    if n > 0 then Dynload.poke_bytes b 0 s;
    note b;
    Dynload.poke_ptr p ptr_off b;
    Dynload.poke_i64 p len_off (Int64.of_int n)
  in
  let seq t xs =
    tag t;
    let n = List.length xs in
    let b = Dynload.take (max (n * form_size) 1) in
    List.iteri
      (fun i x -> write sites (Nativeint.add b (Nativeint.of_int (i * form_size))) x)
      xs;
    note b;
    Dynload.poke_ptr p ptr_off b;
    Dynload.poke_i64 p len_off (Int64.of_int n)
  in
  match f.Form.v with
  | Form.Sym s -> str TSym s
  | Form.Kw s -> str TKw s
  | Form.Str s -> str TStr s
  | Form.Int i -> tag TInt; Dynload.poke_i64 p payload i
  (* Crosses as an [Int] carrying a token; see [wides]. *)
  | Form.UInt (i, text) ->
    tag TInt;
    Dynload.poke_i64 p payload i;
    let token = Int64.logor wide_mark (Int64.of_int (Hashtbl.length !wides)) in
    Hashtbl.replace !wides token (i, text);
    Dynload.poke_i64 p len_off token
  | Form.Float x -> tag TFloat; Dynload.poke_f64 p payload x
  | Form.Byte b -> tag TByte; Dynload.poke_i32 p payload (Int32.of_int b)
  | Form.List xs -> seq TList xs
  | Form.Vec xs -> seq TVec xs
  | Form.Map xs -> seq TMap xs

(* ── Reading one back ──────────────────────────────────────────────
   Three ways a node gets a location, and which one applies is decided by the
   table above.

   A hit is a form the author wrote: it went in on some line, the macro passed
   it through, and it comes back with the pointer it went in with. It keeps its
   own line, tagged with the macro whose call it was written inside — so the
   error is reported where the code is and the [note:] still says which call
   put it there.

   A miss is a node the macro built, and it has no line of its own anywhere. It
   takes the nearest enclosing node that did have one, which is the smallest
   piece of what the author wrote that contains it. Only a node with no located
   ancestor at all falls back to the call site, and that means the whole
   subtree was the macro's invention.

   [Int], [Float] and [Byte] are always a miss, because their payload is the
   value and there is no pointer to ask about — reading one as an address would
   be a number pretending to be a node. So a bad [5] in [(foo (bar 5))] is
   reported at [(bar 5)], the nearest thing that has a place. That is the same
   line SBCL draws: its [source-form-has-path-p] excludes symbols, fixnums and
   characters for the same reason. *)

let rec unmarshal ~(sites : sites) ~loc (p : Dynload.addr) : Form.t =
  let ptr () = Dynload.peek_ptr p ptr_off in
  let len () = Int64.to_int (Dynload.peek_i64 p len_off) in
  let str () = let n = len () in if n = 0 then "" else Dynload.peek_bytes (ptr ()) 0 n in
  (* The node's own location, or the one it inherits. [Loc.from_macro] is
     outermost-wins and the call site is already tagged, so a form that came
     through two expansions keeps the name of the macro the author wrote. *)
  let here () =
    match Hashtbl.find_opt sites (ptr ()) with
    | None -> loc
    | Some own ->
      (match loc.Loc.macro with
       | None -> own
       | Some m -> Loc.from_macro ~at:(Loc.call_site loc) m own)
  in
  let seq loc =
    let b = ptr () and n = len () in
    List.init n (fun i ->
      unmarshal ~sites ~loc (Nativeint.add b (Nativeint.of_int (i * form_size))))
  in
  match tag_of_int (Dynload.peek_i32 p 0) with
  | TInt ->
    let i = Dynload.peek_i64 p payload in
    (match Hashtbl.find_opt !wides (Dynload.peek_i64 p len_off) with
     | Some (w, text) when Int64.equal w i -> Form.make (Form.UInt (i, text)) loc
     | _ -> Form.make (Form.Int i) loc)
  | TFloat -> Form.make (Form.Float (Dynload.peek_f64 p payload)) loc
  | TByte ->
    (* A char is a code point; anything that is not a scalar value keeps the
       byte it always was. *)
    let b = Int32.to_int (Dynload.peek_i32 p payload) in
    Form.make (Form.Byte (if Uchar.is_valid b then b else b land 0xff)) loc
  | TSym -> Form.make (Form.Sym (str ())) (here ())
  | TKw -> Form.make (Form.Kw (str ())) (here ())
  | TStr -> Form.make (Form.Str (str ())) (here ())
  | TList -> let l = here () in Form.make (Form.List (seq l)) l
  | TVec -> let l = here () in Form.make (Form.Vec (seq l)) l
  | TMap -> let l = here () in Form.make (Form.Map (seq l)) l

(* ── One call ──────────────────────────────────────────────────────
   The arguments are one contiguous run of Forms, not an array of pointers,
   because the macro's parameter is [[Form]] and a Flan slice is { ptr, len }
   over elements. *)

let call ~loc (fn : Dynload.addr) (args : Form.t list) : Form.t =
  let n = List.length args in
  (* This call's, and no other's. Nothing [Dynload] hands out is freed before
     the whole expansion is over — [Dynload.release] runs between the rounds in
     [Macro] and on the way out of one — so no address recorded here can be
     handed to a second allocation while the table still holds it, and the
     table is dropped the moment this returns either way. *)
  let sites : sites = Hashtbl.create 8 in
  wides := Hashtbl.create 1;
  let a = Dynload.take (max (n * form_size) 1) in
  List.iteri
    (fun i x -> write sites (Nativeint.add a (Nativeint.of_int (i * form_size))) x)
    args;
  let out = Dynload.take form_size in
  Dynload.call fn a (Int64.of_int n) out;
  unmarshal ~sites ~loc out

(* ── Quasiquote ────────────────────────────────────────────────────
   A desugaring over [Form], and nothing more: a quasiquoted (if ~t ~b) becomes
   calls to the prelude's form-building surface, which the checker then sees as
   ordinary code. There is no quasiquote left in the language after this runs,
   which is why the expander's own walk needs no idea that quoting exists: by
   the time it looks for macro calls, a [cond] written inside a quasiquote is a
   (Form.Sym {.s "cond"}) and there is no head there to mistake for a call the
   compiler should make now.

   The reader stays dumb and produces (quasiquote x), (unquote x) and
   (unquote-splicing x) with no idea whether one is inside another. Counting
   levels is this file's job, done in [quote] below. A macro that writes a
   macro is the only thing that wants a quasiquote inside a quasiquote. *)

let sym loc s = Form.make (Form.Sym s) loc
let lst loc xs = Form.make (Form.List xs) loc

(* (Form.Case {.field value}) — a node of the image, written as the Flan
   constructor the prelude declares. *)
let node loc case field v =
  lst loc [ sym loc ("Form." ^ case);
            Form.make (Form.Map [ sym loc ("." ^ field); Form.make v loc ]) loc ]

let unquote_of (f : Form.t) =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "unquote"; _ }; x ] -> Some x
  | _ -> None

let splice_of (f : Form.t) =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "unquote-splicing"; _ }; x ] -> Some x
  | _ -> None

(* [depth] is how many quasiquotes enclose [f], counting the one being
   desugared as 1 — SBCL's [*backquote-depth*] in src/code/backq.lisp. A
   quasiquote inside raises it and an unquote lowers it, so an unquote belongs
   to the innermost quasiquote around it and [~~x] reaches out two. Only the
   unquotes at depth 1 are evaluated now; the rest are data, rebuilt as the
   (unquote x) and (quasiquote x) forms they were read as, for the macro the
   output defines to desugar in its turn. *)
let rec quote ?(depth = 1) (f : Form.t) : Form.t =
  let loc = f.Form.loc in
  (* (head x) as a Form, [x] already desugared. *)
  let wrapped head x =
    node loc "List" "xs"
      (lst loc [ sym loc "form-cons"; node loc "Sym" "s" (Form.Str head);
                 lst loc [ sym loc "form-cons"; x; lst loc [ sym loc "form-nil" ] ] ]).Form.v
  in
  match unquote_of f with
  (* The escape: whatever the program wrote, evaluated. It is already a Form,
     because a Form is what a macro body deals in. *)
  | Some x when depth = 1 -> x
  | Some x -> wrapped "unquote" (quote ~depth:(depth - 1) x)
  | None ->
    match splice_of f with
    | Some _ when depth = 1 ->
      Loc.fail loc
        "~@x splices into a list or a vector, and there is nothing here for it \
         to splice into"
    | Some x -> wrapped "unquote-splicing" (quote ~depth:(depth - 1) x)
    | None ->
      match f.Form.v with
      | Form.List [ { Form.v = Form.Sym "quasiquote"; _ }; x ] ->
        wrapped "quasiquote" (quote ~depth:(depth + 1) x)
      | Form.Sym s -> node loc "Sym" "s" (Form.Str s)
      | Form.Kw s -> node loc "Kw" "s" (Form.Str s)
      | Form.Int i | Form.UInt (i, _) -> node loc "Int" "i" (Form.Int i)
      | Form.Float x -> node loc "Float" "x" (Form.Float x)
      | Form.Str s -> node loc "Str" "s" (Form.Str s)
      | Form.Byte b -> node loc "Byte" "b" (Form.Int (Int64.of_int b))
      | Form.List xs -> node loc "List" "xs" (seq ~depth loc xs).Form.v
      | Form.Vec xs -> node loc "Vec" "xs" (seq ~depth loc xs).Form.v
      | Form.Map xs -> node loc "Map" "xs" (seq ~depth loc xs).Form.v

(* The [Form] slice one bracket's worth of items comes to. Built right to left,
   so each item is consed onto what follows it and a splice is an append — the
   three prelude functions and no fourth. A splice deeper than [depth] 1 is
   data like any other item. *)
and seq ~depth loc items =
  List.fold_left
    (fun acc (item : Form.t) ->
       match spliced ~depth item with
       | Some x -> lst item.Form.loc [ sym item.Form.loc "form-append"; x; acc ]
       | None ->
         lst item.Form.loc [ sym item.Form.loc "form-cons"; quote ~depth item; acc ])
    (lst loc [ sym loc "form-nil" ])
    (List.rev items)

(* The slice an item splices in, when it splices at all. At depth 1 that is
   ~@x. Deeper, an unquote whose own argument splices at the level below —
   [~~@xs] — splices too: one (unquote x) per element, which is SBCL's
   [unquote*] in src/code/backq.lisp, so the inner template receives ~a ~b ~c.
   [~@~@xs] is the same with (unquote-splicing x). *)
and spliced ~depth (item : Form.t) : Form.t option =
  let loc = item.Form.loc in
  match splice_of item with
  | Some x when depth = 1 -> Some x
  | _ when depth = 1 -> None
  | _ ->
    let wrap head x =
      match spliced ~depth:(depth - 1) x with
      | Some e ->
        Some (lst loc [ sym loc "form-wrap-each"; Form.make (Form.Str head) loc; e ])
      | None -> None
    in
    match unquote_of item, splice_of item with
    | Some x, _ -> wrap "unquote" x
    | _, Some x -> wrap "unquote-splicing" x
    | None, None -> None

(* Every quasiquote in a form, outermost first. Pure, total, and dependent on
   nothing but Form, which is what lets [Parse] run it on the way in rather
   than needing the whole expander wired up first. *)
let rec quasiquote (f : Form.t) : Form.t =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "quasiquote"; _ }; x ] -> quote x
  | Form.List xs -> Form.make (Form.List (List.map quasiquote xs)) f.Form.loc
  | Form.Vec xs -> Form.make (Form.Vec (List.map quasiquote xs)) f.Form.loc
  | Form.Map xs -> Form.make (Form.Map (List.map quasiquote xs)) f.Form.loc
  | _ -> f

(* ── A macro's parameter list ──────────────────────────────────────
   [(defmacro do-grid [[r rows c cols] & body] ...)] — positional parameters,
   a destructuring vector wherever one is written, and [&] for the tail. The
   grammar is [dvec]'s (lib/parse.ml), read over [Form] instead of over the
   values a [let] binds, because a macro's arguments *are* Forms.

   It lives here rather than in [Parse] because both sides of the feature need
   it and they are on opposite sides of the parser: [Parse] turns the list into
   the bindings a macro body opens with, and [Macro] checks a call against it
   before the macro is ever run. This file is below both and depends on nothing
   above [Form], which is what lets them share one reading of the list.

   Map destructuring is not here. [dmap] is [{:keys [x y]}] over a *struct*, and
   a macro's argument is a [Form] whose [Map] case is a flat list of alternating
   forms with no field names in it at all — the pattern would have to mean
   something new rather than the same thing over a different value. Refused by
   name below, and written down in TODO.org, "Map destructuring in a macro's
   parameter list". *)

type pat =
  | Pname of string * Loc.t
  (* A [ ] in the parameter list: the argument at this position must be a
     [Form.Vec], and its elements are matched against these in turn. *)
  (* The [Form] is the pattern as written: a refusal shows the shape the call
     failed to match, and nothing else can render it back. *)
  | Pvec of pat list * (string * Loc.t) option * Form.t

type msig = {
  ps   : pat list;                  (* the positional parameters, in order *)
  rest : (string * Loc.t) option;   (* [& name], if there is one *)
  src  : Form.t;                    (* the list as written, for the messages *)
}

(* [a b & rest], shared by the top level and by every destructuring vector
   inside it. The three refusals are [dvec]'s, word for word where they say the
   same thing: one grammar, so one set of sentences about getting it wrong. *)
let split_amp (items : Form.t list) : Form.t list * (string * Loc.t) option =
  let rec go acc = function
    | [] -> (List.rev acc, None)
    | ({ Form.v = Form.Sym "&"; _ } as amp) :: rest ->
      (match rest with
       | [ { Form.v = Form.Sym r; loc } ] -> (List.rev acc, Some (r, loc))
       | [] -> Loc.fail amp.Form.loc "& needs a name after it, as in [a b & rest]"
       | [ bad ] ->
         Loc.fail bad.Form.loc
           "& binds one name for the rest of the arguments, and %s is not one \
            — the rest is a slice of forms, so it cannot be destructured \
            further"
           (Form.to_string bad)
       | _ :: extra :: _ ->
         Loc.fail extra.Form.loc
           "& takes one name and it is the last thing in the parameter list")
    | x :: rest -> go (x :: acc) rest
  in
  go [] items

(* Never handed a [&]: every list of items reaching here has been through
   [split_amp], which stops at the first one and refuses every way of getting
   the tail wrong itself. So there is no arm for it and no sentence about it. *)
let rec pat_of (f : Form.t) : pat =
  match f.Form.v with
  | Form.Sym s -> Pname (s, f.Form.loc)
  | Form.Vec items ->
    let elems, rest = split_amp items in
    (match elems, rest with
     | [], None ->
       Loc.fail f.Form.loc
         "an empty pattern [] in a macro's parameter list binds nothing — \
          write the names it should bind"
     | [], Some (r, loc) ->
       Loc.fail loc
         "[& %s] binds the whole vector — write %s on its own instead of a \
          pattern" r r
     | _ -> ());
    Pvec (List.map pat_of elems, rest, f)
  | Form.Map _ ->
    Loc.fail f.Form.loc
      "map destructuring is not implemented in a macro's parameter list — a \
       macro's argument is a Form, whose Map case is a flat run of alternating \
       forms with no fields to name. Take the form and pick it apart in the \
       body"
  | _ ->
    Loc.fail f.Form.loc
      "a macro's parameter is a name or a [ ] pattern over one, and %s is \
       neither"
      (Form.to_string f)

(* Every name the list binds, so that two of them can be refused where they are
   written rather than reaching the checker as a local declared twice. *)
let rec pat_names acc = function
  | Pname (s, loc) -> (s, loc) :: acc
  | Pvec (ps, rest, _) ->
    let acc = List.fold_left pat_names acc ps in
    (match rest with None -> acc | Some nl -> nl :: acc)

let params_of (v : Form.t) : msig =
  let items = match v.Form.v with
    | Form.Vec items -> items
    | _ ->
      Loc.fail v.Form.loc "a macro's parameter list is written in [ ], and %s is not"
        (Form.to_string v)
  in
  let elems, rest = split_amp items in
  let sg = { ps = List.map pat_of elems; rest; src = v } in
  let names = List.fold_left pat_names [] sg.ps in
  let names =
    match sg.rest with None -> names | Some nl -> nl :: names in
  let seen = Hashtbl.create 8 in
  List.iter
    (fun (n, loc) ->
       if Hashtbl.mem seen n then
         Loc.fail loc "%s is bound twice in this parameter list" n
       else Hashtbl.add seen n ())
    (List.rev names);
  sg

(* ── Checking a call against it ────────────────────────────────────
   Before expansion, so the refusal is about the call as it is written and
   points at it. That is the whole reason this is a separate pass rather than
   something the macro body could do: a macro has no error facility, and a call
   that does not fit the parameter list is a mistake in the call rather than in
   anything the expansion would go on to produce. *)

let written (sg : msig) = Form.to_string sg.src

let arity (sg : msig) ~name ~loc (args : Form.t list) =
  let n = List.length sg.ps in
  let got = List.length args in
  let plural k = if k = 1 then "argument" else "arguments" in
  match sg.rest with
  | Some (r, _) when got < n ->
    Loc.fail loc
      "%s takes at least %d %s and this call gives %d — its parameter list is \
       %s, where &%s is the rest"
      name n (plural n) got (written sg) r
  | Some _ -> ()
  | None when got <> n ->
    Loc.fail loc
      "%s takes %d %s and this call gives %d — its parameter list is %s"
      name n (plural n) got (written sg)
  | None -> ()

let rec check_pat ~name (p : pat) (a : Form.t) =
  match p with
  | Pname _ -> ()
  | Pvec (ps, rest, src) ->
    let items =
      match a.Form.v with
      | Form.Vec items -> items
      | _ ->
        Loc.fail a.Form.loc
          "%s destructures this argument with %s, so a [ ] belongs here and \
           %s was written"
          name (Form.to_string src) (Form.to_string a)
    in
    let n = List.length ps in
    let got = List.length items in
    if (rest = None && got <> n) || got < n then
      Loc.fail a.Form.loc
        "%s destructures this argument with %s, which takes %s%d, and %d %s \
         written here"
        name (Form.to_string src)
        (if rest = None then "" else "at least ")
        n got (if got = 1 then "is" else "are");
    List.iteri (fun i q -> check_pat ~name q (List.nth items i)) ps

let check_call ~name ~loc (sg : msig) (args : Form.t list) =
  arity sg ~name ~loc args;
  List.iteri (fun i p -> check_pat ~name p (List.nth args i)) sg.ps