diff --git a/lib/dev.ml b/lib/dev.ml index bdf2443..0206371 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -235,7 +235,15 @@ let restarts t = framing [restarts] uses, terminated by a lone dot, because it comes back over the same one-line-out socket. - Each line is [I ± NSLOTS LOC NAME]. The flag says whether the frame belongs + Each line is [I ± NSLOTS SIG LOC NAME]. [SIG] is the slot fingerprint of + the body this frame was compiled from — [Emit.slot_fingerprint] over the + name and the type of every slot — and it is how [locals] tells a frame whose + body has been redefined underneath it from one that still matches. It stays + off the wire: a hash is not something a client can act on, and the refusal + it produces says the fact in words instead. It sits before [LOC] because + [NAME] is the only field that can contain a space and so has to be last. + + The flag says whether the frame belongs to the program or to the C-x C-e thunk the break happens to be inside: a break inside an evaluation has that evaluation's frames on top, and answering "where is my program" with [eval/7] would be true and useless. @@ -264,11 +272,14 @@ let backtrace t = end else match String.split_on_char ' ' line with - | idx :: flag :: nslots :: loc :: rest when rest <> [] -> - (match int_of_string_opt idx, int_of_string_opt nslots with - | Some _, Some k -> + | idx :: flag :: nslots :: sig_ :: loc :: rest when rest <> [] -> + (match + int_of_string_opt idx, int_of_string_opt nslots, + int_of_string_opt sig_ + with + | Some _, Some k, Some g -> Some (String.concat " " rest, (if loc = "?" then "" else loc), - flag = "+", k) + flag = "+", k, g) | _ -> None) | _ -> None in @@ -700,7 +711,7 @@ let backtrace_op t = [ ":frames " ^ Wire.list (List.map - (fun (name, loc, mine, nslots) -> + (fun (name, loc, mine, nslots, _sig) -> Wire.list [ Wire.quote name; Wire.quote loc; Wire.quote (if mine then "program" else "eval"); @@ -731,9 +742,17 @@ let backtrace_op t = showed neither would be the same lie twice. And two whole frames it refuses: one belonging to a [C-x C-e] thunk, which - this session does not keep the [Tast] of, and one whose slot count does not - match the body this session holds — which is a frame running a body that - has since been redefined, where every slot index would be a guess. *) + this session does not keep the [Tast] of, and one whose *body* is not the + body this session holds. The second is the one that needed a fingerprint + rather than a count: installing while stopped is deliberately allowed — it + is the fix-it-and-retry loop — so the frame on the stack and the body here + can be two bodies of one function, and a redefinition that renames a local + changes neither the count nor the types. [Emit.slot_fingerprint] hashes + every slot's name together with the spelling of its type, the frame carries + the value for the body it was compiled from, and this end recomputes it + from the body it holds. A collision is possible in principle — it is a + 30-bit hash — but only between two differing bodies of the function whose + qualified name already matched, since [find_fn] gates the comparison. *) let locals t ~frame = if not (alive t) then error "the program exited; restart flan dev" else @@ -752,7 +771,7 @@ let locals t ~frame = error (Printf.sprintf "there is no frame %d; the backtrace has %d" frame (List.length frames)) - | Some (name, _, mine, nslots) -> + | Some (name, _, mine, nslots, sig_) -> if not mine then error (name @@ -775,6 +794,19 @@ let locals t ~frame = (Printf.sprintf "%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess" name nslots name (Array.length fn.Tast.slots)) + else if sig_ <> Emit.slot_fingerprint fn then + (* The count matching is not the same as the body matching. + A redefinition that renames a local, or changes its type + to one of the same shape, keeps the count — and then + every name here would be the new body's read against the + old body's storage, which is the "visible rather than + correct" answer this project refuses to give. Said by + name, because a frame that is missing and a frame that + cannot be trusted are different facts. *) + error + (Printf.sprintf + "%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values" + name name) else match bound_slots t ~frame with | Error m -> error ("the program refused to say which slots are bound: " ^ m) diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 0be0ba9..0293214 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -335,7 +335,13 @@ typedef struct { const char *loc; /* file:line:col, as Loc spells it */ int64_t loclen; int32_t nslots; - int32_t spare; + /* What the two ends compare about a frame's slots, from + [Emit.slot_fingerprint]: a hash over every slot's name and the spelling of + its type. The frame carries the one belonging to the body it was compiled + from; the daemon recomputes it from the body it now holds, and a + difference means the frame is running a superseded body. A count alone + cannot see a rename, which is the case this exists for. */ + int32_t slotsig; } flan_fninfo; typedef struct flan_frame { @@ -390,6 +396,14 @@ int32_t flan_dev_frame_nslots(const void *frame) { return (f == NULL || f->info == NULL) ? 0 : f->info->nslots; } +/* The fingerprint of the body this frame was compiled from. Zero for a frame + * with no description, which is the same "nothing to compare" a zero slot + * count already means. */ +int32_t flan_dev_frame_slotsig(const void *frame) { + const flan_frame *f = frame; + return (f == NULL || f->info == NULL) ? 0 : f->info->slotsig; +} + /* Where slot [i] of this frame lives, or NULL — which means one of three * things, all of which are "there is nothing to read here": this build records * no slots, the index is not one of them, or the binding that fills it had not diff --git a/test/test_dev.ml b/test/test_dev.ml index 84a8662..264ba63 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -806,6 +806,24 @@ let () = let r = ask "(:op \"locals\" :frame 9)" in if status r <> "error" then fail "a frame index past the end answered"; + (* The inverse, first, because it is the cheap half of the same + claim: a redefinition that really does change the slots must be + refused too, and that one a count comparison can see. This body + drops [flag] and keeps the signature, so the frame on the stack has + one slot more than the body this session now holds. *) + let r = + ask + "(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [p (Point {:x 1.5 :y 2.5}) xs [10 20 30]] (restart-case (do (error (Boom {:why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then + fail "installing a body with fewer slots while stopped: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + let r = ask "(:op \"locals\" :frame 0)" in + if status r <> "error" then + fail "the frame of a body whose slots changed answered anyway" + end; + (* And the case that makes this a fingerprint rather than a slot count. Installing while stopped is deliberately allowed — it is the fix-it-and-retry loop — so the body on the stack and the body the @@ -823,7 +841,16 @@ let () = else begin let r = ask "(:op \"locals\" :frame 0)" in if status r <> "error" then - fail "the frame of a superseded body answered with the new body's names" + fail "the frame of a superseded body answered with the new body's names"; + (* And the other half of that claim, which is the one a fingerprint + that never matched would fail: redefining [look] says nothing + about [main], and its frame must still answer. A refusal that + fires for every frame would pass the test above and make the + whole verb useless. *) + let r = ask "(:op \"locals\" :frame 1)" in + if status r <> "ok" then + fail "redefining one function refused an untouched frame: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")) end end; (* Running again, and then the locals verb is refused: a frame that is diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 24f3e54..1479ab8 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -155,6 +155,7 @@ extern void *flan_dev_frame_at(int32_t i); extern const char *flan_dev_frame_name(const void *frame, int64_t *len); extern const char *flan_dev_frame_loc(const void *frame, int64_t *len); extern int32_t flan_dev_frame_nslots(const void *frame); +extern int32_t flan_dev_frame_slotsig(const void *frame); extern void *flan_dev_frame_slot(const void *frame, int32_t i); extern const uint8_t *flan_restart_name(int32_t i, int64_t *len); extern void *flan_restart_frame(int32_t i); @@ -259,6 +260,8 @@ typedef struct { int32_t fnoff[FRAME_MAX], fnlen[FRAME_MAX]; int32_t floff[FRAME_MAX], fllen[FRAME_MAX]; int32_t fslots[FRAME_MAX]; + int32_t fsig[FRAME_MAX]; /* the slot fingerprint of the body + * this frame was compiled from */ int32_t fmine[FRAME_MAX]; /* 0 = the evaluation's, not the * program's */ char ftext[FRAME_TEXT]; @@ -363,6 +366,10 @@ static int snap_push(void) { s->fused += (int32_t)ll; s->ftext[s->fused++] = 0; s->fslots[s->fn] = flan_dev_frame_nslots(fr); + /* Snapshotted with the rest of the frame rather than read later: the + * module this description lives in can be unloaded once the daemon + * installs a replacement, and the comparison happens after that. */ + s->fsig[s->fn] = flan_dev_frame_slotsig(fr); /* The outermost [frame_floor] frames are the program's; anything above * them belongs to the evaluation this break is inside. */ s->fmine[s->fn] = (frame_floor < 0) || (i >= fn - frame_floor); @@ -667,8 +674,11 @@ static void serve(int fd) { } for (int32_t i = 0; i < s->fn; i++) { char hdr[64]; - int k = snprintf(hdr, sizeof hdr, "%d %c %d ", i, - s->fmine[i] ? '+' : '-', s->fslots[i]); + /* The fingerprint goes before the location and the location before + * the name, because the name is the one field that can contain a + * space and so has to be last. */ + int k = snprintf(hdr, sizeof hdr, "%d %c %d %d ", i, + s->fmine[i] ? '+' : '-', s->fslots[i], s->fsig[i]); if (k > 0) send(fd, hdr, (size_t)k, MSG_NOSIGNAL); if (s->fllen[i] > 0) send(fd, s->ftext + s->floff[i], (size_t)s->fllen[i], MSG_NOSIGNAL);