A generic's copy made by an evaluated expression is disassembled from that expression's module, and one copy that cannot be shown no longer hides the others
This commit is contained in:
parent
6c8611cece
commit
77497cfc2c
@ -3056,7 +3056,11 @@ the types its variables were bound to."
|
||||
(insert "\n")
|
||||
(flan-disassemble--comment
|
||||
(format ";; %s at %s" (plist-get c :generic) (plist-get c :types)))
|
||||
(flan-disassemble--listing c)))
|
||||
(if (plist-get c :refused)
|
||||
(progn
|
||||
(flan-disassemble--header "signature" (plist-get c :signature))
|
||||
(flan-disassemble--header "no listing" (plist-get c :refused)))
|
||||
(flan-disassemble--listing c))))
|
||||
(flan-disassemble--comment
|
||||
(if (plist-get r :generic)
|
||||
(format "; %s for %s at %s" what (plist-get r :generic)
|
||||
|
||||
63
lib/dev.ml
63
lib/dev.ml
@ -668,9 +668,9 @@ let generic_signature t name =
|
||||
(String.concat " " (List.map show params)) (show ret))
|
||||
|
||||
(* The copies of generic [name] the program holds, each with the types its
|
||||
variables were bound to, spelled [$t = i32]. Read off the program and not
|
||||
off the instantiation table: a copy a [C-x C-e] thunk asked for is in the
|
||||
table and in no program, and there is no build of it to show. *)
|
||||
variables were bound to, spelled [$t = i32]. Read off the program: a copy
|
||||
a [C-x C-e] made is kept in it, and [eval_expr] records the thunk's module
|
||||
as that copy's owner, since no other module defines it. *)
|
||||
let generic_copies t name =
|
||||
let env = t.session.Session.env in
|
||||
match Hashtbl.find_opt env.Check.gsigs name with
|
||||
@ -1099,6 +1099,9 @@ let eval_expr t ~code ~origin ~pause =
|
||||
the same instantiation would list it as already there. *)
|
||||
let held = Session.held t.session in
|
||||
let refused msg = Session.restore t.session held; error msg in
|
||||
let had =
|
||||
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
|
||||
in
|
||||
match Session.eval_expr ~origin ~pause t.session code with
|
||||
| c ->
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
@ -1130,10 +1133,32 @@ let eval_expr t ~code ~origin ~pause =
|
||||
let entered_gen = stop_gen t in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in
|
||||
(* A generic called at a new type makes a copy that is defined in this
|
||||
thunk's module and in no other, so this module is where [disassemble]
|
||||
has to look for it — and its IR is kept for the reason [eval] keeps
|
||||
a module's. *)
|
||||
let ll =
|
||||
Filename.concat t.dir (Printf.sprintf "e%d%s" t.n (module_ext c))
|
||||
in
|
||||
write_file ll c.Session.ir;
|
||||
let copies =
|
||||
List.filter_map
|
||||
(fun (f : Tast.fn) ->
|
||||
if List.mem f.Tast.name had then None else Some f.Tast.name)
|
||||
t.session.Session.program.Tast.fns
|
||||
in
|
||||
(match build_module c ~debug:t.session.Session.debug ~out with
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
| "ok" ->
|
||||
if copies <> [] then begin
|
||||
t.gen <- t.gen + 1;
|
||||
List.iter
|
||||
(fun n ->
|
||||
Hashtbl.replace t.owners n
|
||||
{ ogen = t.gen; oso = out; oll = ll; oloc = fn_loc t n })
|
||||
copies
|
||||
end;
|
||||
(* Strictly after the delivery, and that ordering is the whole of
|
||||
it: the sleeper is woken to look at a ring, so waking it before
|
||||
the module is in one buys an empty poll and a five-second wait.
|
||||
@ -3936,21 +3961,25 @@ let disassemble t ~name ~form =
|
||||
| [ c ] ->
|
||||
(match copy c with Ok fields -> ok fields | Error m -> error m)
|
||||
| cs ->
|
||||
let rec all acc = function
|
||||
| [] -> Ok (List.rev acc)
|
||||
| c :: rest ->
|
||||
(match copy c with
|
||||
| Ok fields -> all (Wire.list fields :: acc) rest
|
||||
| Error m -> Error m)
|
||||
(* One copy that cannot be shown is that copy's entry, named with
|
||||
the reason, and not the whole reply: the others still have code
|
||||
to read. *)
|
||||
let entry (((f : Tast.fn), bound) as c) =
|
||||
match copy c with
|
||||
| Ok fields -> Wire.list fields
|
||||
| Error m ->
|
||||
Wire.list
|
||||
[ ":name " ^ Wire.quote f.Tast.name;
|
||||
":signature " ^ Wire.quote (signature_of_fn f);
|
||||
":loc " ^ Wire.quote (fn_loc t f.Tast.name);
|
||||
":generic " ^ Wire.quote name; ":types " ^ Wire.quote bound;
|
||||
":refused " ^ Wire.quote m ]
|
||||
in
|
||||
(match all [] cs with
|
||||
| Error m -> error m
|
||||
| Ok copies ->
|
||||
ok
|
||||
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
|
||||
":generic " ^ Wire.quote name;
|
||||
":signature " ^ Wire.quote sign;
|
||||
":copies " ^ Wire.list copies ]))
|
||||
ok
|
||||
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
|
||||
":generic " ^ Wire.quote name;
|
||||
":signature " ^ Wire.quote sign;
|
||||
":copies " ^ Wire.list (List.map entry cs) ])
|
||||
| None ->
|
||||
(match kind_of t name with
|
||||
| Some k ->
|
||||
|
||||
@ -3400,6 +3400,47 @@ let () =
|
||||
if text = "" then fail "%s: the copy %s has no listing" backend name)
|
||||
[ a; b ]
|
||||
| _ -> fail "%s: two copies did not come back as two" backend
|
||||
end;
|
||||
(* A copy made by an evaluated expression is defined only in that
|
||||
expression's module, which is where its code has to be read from —
|
||||
and the copies made before it are still shown beside it. *)
|
||||
let r =
|
||||
request c
|
||||
"(:op \"eval-expr\" :code \"(selection-sort (slice [(i64 3) (i64 1)] 0 2))\")"
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "%s: calling the generic at i64 from an expression: %s" backend (said r)
|
||||
else begin
|
||||
let r = ask () in
|
||||
if status r <> "ok" then
|
||||
fail "%s: the generic with a copy an expression made: %s" backend (said r)
|
||||
else
|
||||
match Wire.field r "copies" with
|
||||
| Some { Form.v = Form.List [ _; _; _ ] as l; _ } ->
|
||||
let l = match l with Form.List l -> l | _ -> [] in
|
||||
List.iter
|
||||
(fun f ->
|
||||
let name = Option.value ~default:"" (Wire.string_field f "name") in
|
||||
match Wire.string_field f "refused" with
|
||||
| Some m -> fail "%s: the copy %s has no listing: %s" backend name m
|
||||
| None ->
|
||||
let text = Option.value ~default:"" (Wire.string_field f "text") in
|
||||
if form = "ir" && not (contains_sub text ("flan." ^ name)) then
|
||||
fail "%s: the copy %s shows some other code" backend name;
|
||||
if text = "" then fail "%s: the copy %s has no listing" backend name)
|
||||
l;
|
||||
(match
|
||||
List.find_opt
|
||||
(fun f -> Wire.string_field f "types" = Some "$t = i64") l
|
||||
with
|
||||
| Some f ->
|
||||
(match Wire.string_field f "object" with
|
||||
| Some o when String.starts_with ~prefix:"e" (Filename.basename o) -> ()
|
||||
| o ->
|
||||
fail "%s: the expression's copy is not read from its module: %s"
|
||||
backend (Option.value ~default:"" o))
|
||||
| None -> fail "%s: the expression's copy is not listed" backend)
|
||||
| _ -> fail "%s: three copies did not come back as three" backend
|
||||
end
|
||||
end
|
||||
in
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user