diff --git a/emacs/flan.el b/emacs/flan.el index 0fd41fcf..2b9b8aad 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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) diff --git a/lib/dev.ml b/lib/dev.ml index 06d3872f..dfe19dda 100644 --- a/lib/dev.ml +++ b/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 -> diff --git a/test/test_dev.ml b/test/test_dev.ml index b0eee8f3..27e5c4d9 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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