diff --git a/lib/x86.ml b/lib/x86.ml index c585400..096382f 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -4922,6 +4922,17 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) \t.size\tflan_reload_transient, 1\n\ flan_reload_transient:\n\t.byte\t1\n" | _ -> ()); + (* The per-type dyn descriptors this module's own bodies asked for, exactly + as [program] emits them. They were missing here, and the hole only became + reachable when a redefined body first constructed a struct holding a dyn: + [desc_of] mints a local label and the body references it, so a module + that never wrote the label out is one [ld] refuses with an undefined + symbol rather than one that loads and reads garbage. The labels are local + in both backends — [desc_of] says so, and this is the other half of that + sentence — so emitting the same type's descriptor here and in the host is + not a duplicate symbol. [Emit.redefinition] has always emitted them, by + going through [finish]. *) + Buffer.add_string out (Emit.descriptors_asm md); Buffer.add_string out "\n\t.section\t.rodata\n"; Buffer.add_buffer out rodata; Buffer.add_string out "\n\t.section\t.note.GNU-stack,\"\",@progbits\n"; diff --git a/test/programs/dev-class.flan b/test/programs/dev-class.flan new file mode 100644 index 0000000..d64371a --- /dev/null +++ b/test/programs/dev-class.flan @@ -0,0 +1,26 @@ +;;;; A class and a generic function, for the dev loop rather than for output. +;;;; +;;;; What a session does with this is the question the feature is judged on: +;;;; adding a method to a running program has to reach the call sites that +;;;; were compiled before the method existed. It does, and the reason is that +;;;; a generic is one function — the methods are branches of its body, not +;;;; functions of their own — so a new method is the ordinary redefinition of +;;;; one name, through the cell the call already goes through. +;;;; +;;;; It keeps running rather than returning, for dev-repl.flan's reason: an +;;;; expression typed at the editor is a thunk the agent runs at a frame +;;;; boundary, and a parked program has none. +(import agent "vendor:agent") + +(defclass point [x y]) +(defclass circle [r]) + +(defgeneric area [self] dyn) + +(defmethod area point [p] (* (get p :x) (get p :y))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-class-fallback.sock") + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/test_dev.ml b/test/test_dev.ml index 0a14909..e8cfbb2 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -4899,6 +4899,91 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ gsock; gout ]; + (* ── A method added to a running program ─────────────────────── + The one claim classes rest on, made end to end rather than at the + session's report: a generic function compiled with one method gets a + second one delivered into the live process, and the call that goes + through its cell answers with the new method's body. The session test + pins which name is installed; this pins that installing it works. + + Its own daemon over [programs/dev-class.flan], which keeps running so + that an expression has a frame boundary to be run at. *) + let csock = tmp "class.sock" and cout = tmp "class.out" in + (try Sys.remove csock with Sys_error _ -> ()); + let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let cpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-class.flan"; "-s"; csock |] + Unix.stdin cfd Unix.stderr + in + Unix.close cfd; + if not (listening ~pid:cpid csock) then begin + fail "the class daemon %s (%S)" !listen_why + (In_channel.with_open_bin cout In_channel.input_all); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect csock in + let said r = Option.value ~default:"" (Wire.string_field r "message") in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + let ask code = + request c + (Printf.sprintf + "(:op \"eval-expr\" :code %S :file \"programs/dev-class.flan\")" + code) + in + (* Every answer is compared inside the expression rather than read out + of it. A generic answers a dyn, and a dyn value is rendered to the + program's own stdout rather than into the reply's :value — it does + reach a later reply's :output, which is how the dyn-global rows + below read one, but the flush is the next reply's and not this one's. + Asking the running program whether the answer is 12 puts a typed + value in :value and takes the timing out of the test. + + The first ask is retried: the agent's thread is let go only after the + socket is bound, so an early ask is a race with the startup and not a + result. *) + let answered = ref "" in + let asked () = + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + status r = "ok" && (answered := value r; true) + in + if not (await asked) then + fail "the class daemon never reached a frame boundary" + else begin + if !answered <> "1" then + fail "the method the program was built with answered %S" !answered; + (* A circle has no method yet, so the dispatch misses and the generic + signals NoMethod — the answer a program handles, spelled here as + the thing that makes the next step's success mean something. *) + let r = + request c + "(:op \"eval\" :code \"(defmethod area circle [q] (* 3 (* (get q \ + :r) (get q :r))))\" :file \"programs/dev-class.flan\")" + in + if status r <> "ok" then fail "delivering a new method: %s" (said r) + else begin + (* The call site in the generic's own cell now reaches a branch that + did not exist when the process started. *) + let r = ask "(if (= (area (circle 2)) 12) 1 0)" in + if status r <> "ok" then + fail "calling a generic after a method was added: %s" (said r) + else if value r <> "1" then + fail "the added method did not answer 12 (%S)" (value r); + (* And the method that was already there still answers, which is + what says the generic was extended rather than replaced. *) + let r = ask "(if (= (area (point 3 4)) 12) 1 0)" in + if value r <> "1" then + fail "the original method stopped answering (%S)" (value r) + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) + [ csock; cout ]; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () diff --git a/test/test_session.ml b/test/test_session.ml index 7351a61..6dff651 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -303,6 +303,53 @@ let () = | _ -> () | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a name added earlier was forgotten: %s" m); + (* ── A method added to a running program ──────────────────────── + The dev loop is what classes were built for, so this is the case that + decides whether the feature is usable at all. A generic function is one + top-level name whose body dispatches, and a method is a branch of it — + so adding a method has to install the *generic's* body, not a function + of the method's own, and it has to do it through the cell the call site + already goes through. If it reported only the method's own declaration + name, [report]'s compiled call to [area] would go on running the body it + was built with and the new method would be invisible. *) + let t, _ = Session.create ~file:"programs/dev-class.flan" () in + let c = Session.eval t "(defmethod area circle [c] (* 3 (* (get c :r) (get c :r))))" in + if not c.Session.installs then + fail "adding a method had nothing to install"; + if not (List.mem "area" c.Session.fns) then + fail "adding a method installed %s, not the generic's body" + (String.concat " " c.Session.fns); + (* Redefining one is the same path, and the declaration is replaced rather + than appended: a second (defmethod area circle ...) is not a duplicate + method, it is this one again. *) + let c = Session.eval t "(defmethod area circle [c] 0)" in + if not (List.mem "area" c.Session.fns) then + fail "redefining a method installed %s" (String.concat " " c.Session.fns); + (* And it stays in the session: the class the method dispatches on, the + generic it extends, and the method itself are all still there for the + next form to check against. *) + (match Session.eval t "(defmethod area point [p] (+ (get p :x) (get p :y)))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a method added earlier left the session broken: %s" m); + (* A method for a class that is not there is refused, and refusing leaves + the session exactly as it was — the same rule every other refusal here + follows. *) + (match Session.eval t "(defmethod area square [s] 1)" with + | _ -> fail "a method dispatching on an unknown class was accepted" + | exception Loc.Error _ -> ()); + (* A whole new class and a method for it, in one form — the shape of + actually growing a program in the loop. The constructor is a name the + process was never built with, so it goes through the registry the way + any added function does, and the generic is redefined around it. *) + let c = + Session.eval t + "(do (defclass square [s]) (defmethod area square [q] (* (get q :s) (get q :s))))" + in + if not (List.mem "square" c.Session.fns && List.mem "area" c.Session.fns) then + fail "adding a class and a method installed %s" + (String.concat " " c.Session.fns); + (* A file with imports, re-evaluated whole — the C-c C-k case. The session keeps the *expanded* declarations, so the package's names are replaced in place rather than appended a second time and rejected as duplicates. *)