C-c C-s installs a defn that stops before each form of its body, and the break buffer steps it with s and runs the rest of the call with c
This commit is contained in:
parent
da9f21ddcd
commit
9a91440486
12
TODO.org
12
TODO.org
@ -2029,14 +2029,10 @@ because =locals= and the inspector are asked by it. The innermost frame is
|
|||||||
shown even when it is the prelude's, unless the stop is =(pause)=, because it
|
shown even when it is the prelude's, unless the stop is =(pause)=, because it
|
||||||
is where the program stopped. Rules out renumbering the visible frames.
|
is where the program stopped. Rules out renumbering the visible frames.
|
||||||
|
|
||||||
** NEXT There is no stepper
|
** DONE There is no stepper
|
||||||
Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=.
|
CLOSED: [2026-09-25]
|
||||||
=(pause)= stops and offers restarts, frames, locals and the inspector, but
|
C-c C-s instruments a defn with a step point before each body form; no step
|
||||||
nothing advances a form at a time. CIDER instruments a form and steps the
|
into a callee, no argument positions, and no value shown after a form.
|
||||||
instrumented copy; the equivalent here is a dev-build-only instrumented
|
|
||||||
redefinition, which the cell indirection already makes deliverable. Open:
|
|
||||||
whether stepping suspends the frame loop, and what it does to a game's clock.
|
|
||||||
|
|
||||||
** DONE A NaN cast says "does not fit", which reads as too big
|
** DONE A NaN cast says "does not fit", which reads as too big
|
||||||
CLOSED: [2026-09-25]
|
CLOSED: [2026-09-25]
|
||||||
Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity,
|
Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity,
|
||||||
|
|||||||
@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled.
|
|||||||
hit it as many times as you like; an ordinary `C-c C-c` over the same form (or
|
hit it as many times as you like; an ordinary `C-c C-c` over the same form (or
|
||||||
`C-c C-k` over the buffer) takes it off.
|
`C-c C-k` over the buffer) takes it off.
|
||||||
|
|
||||||
|
**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops
|
||||||
|
before each form of its body. Each stop is a break like `(pause)`, and the
|
||||||
|
source of the form about to run is shown beside it. `s` goes to the next form,
|
||||||
|
`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the
|
||||||
|
same form installs it plain.
|
||||||
|
|
||||||
`C-u C-x C-e` does the same for the expression before point: it stops *at* the
|
`C-u C-x C-e` does the same for the expression before point: it stops *at* the
|
||||||
expression instead of printing its value. That one does not stick, because there
|
expression instead of printing its value. That one does not stick, because there
|
||||||
is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is
|
is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is
|
||||||
@ -375,6 +381,9 @@ Keys in that buffer:
|
|||||||
| `v` | visit the source of the frame at point |
|
| `v` | visit the source of the frame at point |
|
||||||
| `P` | show or hide the prelude's frames |
|
| `P` | show or hide the prelude's frames |
|
||||||
| `i` | inspect the local or global at point |
|
| `i` | inspect the local or global at point |
|
||||||
|
| `e` | evaluate an expression in the frame at point; it sees that frame's locals |
|
||||||
|
| `s` | at a step, go to the next form |
|
||||||
|
| `c` | take `continue`: at a step, run the rest of the call |
|
||||||
| `a` | abort |
|
| `a` | abort |
|
||||||
| `g` | read the program again |
|
| `g` | read the program again |
|
||||||
| `q` | close the buffer |
|
| `q` | close the buffer |
|
||||||
|
|||||||
@ -63,6 +63,7 @@
|
|||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(require 'seq)
|
(require 'seq)
|
||||||
|
(require 'pulse)
|
||||||
(require 'subr-x)
|
(require 'subr-x)
|
||||||
(require 'flan-mode)
|
(require 'flan-mode)
|
||||||
|
|
||||||
@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the
|
|||||||
first place that can tell the difference. Named here rather than spelled at
|
first place that can tell the difference. Named here rather than spelled at
|
||||||
its use, because it is a fact about the prelude.")
|
its use, because it is a fact about the prelude.")
|
||||||
|
|
||||||
|
(defconst flan-cnr-step "StepPoint"
|
||||||
|
"The condition the stepper's `(step-point)' signals, before each form of a
|
||||||
|
defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue'
|
||||||
|
restarts: `s' takes the first and `c' the second.")
|
||||||
|
|
||||||
|
(defun flan-cnr--stepping-p (state)
|
||||||
|
"Whether STATE is a stop of the stepper."
|
||||||
|
(equal (plist-get state :condition) flan-cnr-step))
|
||||||
|
|
||||||
(defun flan-cnr--headline-fields (fields)
|
(defun flan-cnr--headline-fields (fields)
|
||||||
"The condition's own numbers, folded into the headline.
|
"The condition's own numbers, folded into the headline.
|
||||||
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
|
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
|
||||||
@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline."
|
|||||||
;; only thing that can be wrong here is the word for it. Calling a
|
;; only thing that can be wrong here is the word for it. Calling a
|
||||||
;; breakpoint unhandled would be a small lie told at the top of the
|
;; breakpoint unhandled would be a small lie told at the top of the
|
||||||
;; one buffer that exists to say what happened.
|
;; one buffer that exists to say what happened.
|
||||||
(paused (equal name flan-cnr-breakpoint))
|
(paused (member name (list flan-cnr-breakpoint flan-cnr-step)))
|
||||||
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
|
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
|
||||||
(insert (propertize name 'face (if paused 'warning 'error)))
|
(insert (propertize name 'face (if paused 'warning 'error)))
|
||||||
(when numbers (insert " — " numbers))
|
(when numbers (insert " — " numbers))
|
||||||
@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline."
|
|||||||
(let ((sentence (plist-get state :sentence)))
|
(let ((sentence (plist-get state :sentence)))
|
||||||
(when sentence (insert sentence "\n")))
|
(when sentence (insert sentence "\n")))
|
||||||
(insert (propertize
|
(insert (propertize
|
||||||
(if paused
|
(cond
|
||||||
"stopped at (pause); nothing has been unwound\n"
|
((flan-cnr--stepping-p state)
|
||||||
"unhandled; stopped where it erred, nothing unwound\n")
|
"stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n")
|
||||||
|
(paused "stopped at (pause); nothing has been unwound\n")
|
||||||
|
(t "unhandled; stopped where it erred, nothing unwound\n"))
|
||||||
'face 'shadow))
|
'face 'shadow))
|
||||||
(flan-cnr--insert-site state))
|
(flan-cnr--insert-site state))
|
||||||
(insert "\n")
|
(insert "\n")
|
||||||
@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program."
|
|||||||
(if (and (not flan-cnr--show-prelude)
|
(if (and (not flan-cnr--show-prelude)
|
||||||
(flan-cnr--prelude-frame-p fr)
|
(flan-cnr--prelude-frame-p fr)
|
||||||
(or (> i 0)
|
(or (> i 0)
|
||||||
(equal (plist-get state :condition) flan-cnr-breakpoint)))
|
(equal (plist-get state :condition) flan-cnr-breakpoint)
|
||||||
|
(flan-cnr--stepping-p state)))
|
||||||
(setq hidden (1+ hidden))
|
(setq hidden (1+ hidden))
|
||||||
(when (> hidden 0)
|
(when (> hidden 0)
|
||||||
(flan-cnr--insert-hidden hidden)
|
(flan-cnr--insert-hidden hidden)
|
||||||
@ -574,7 +587,7 @@ puts the likely culprit on top."
|
|||||||
;; an entry is annotated with have to be on screen above it to read.
|
;; an entry is annotated with have to be on screen above it to read.
|
||||||
(flan-cnr--insert-globals state)
|
(flan-cnr--insert-globals state)
|
||||||
(insert (propertize
|
(insert (propertize
|
||||||
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame a abort g refresh q quit\n"
|
"RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue a abort g refresh q quit\n"
|
||||||
'face 'shadow))
|
'face 'shadow))
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
;; Point starts on the restart that abandons the evaluation, when there is
|
;; Point starts on the restart that abandons the evaluation, when there is
|
||||||
@ -861,6 +874,41 @@ local of, and CODE is read from the minibuffer."
|
|||||||
v)
|
v)
|
||||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
|
||||||
|
|
||||||
|
(defun flan-cnr--take-named (name)
|
||||||
|
"Take the innermost restart called NAME, or refuse by name."
|
||||||
|
(let ((i (seq-position (plist-get flan-cnr--state :restarts) name)))
|
||||||
|
(unless i (user-error "flan: there is no %s restart at this stop" name))
|
||||||
|
(flan-cnr--invoke i name)))
|
||||||
|
|
||||||
|
(defun flan-cnr-step ()
|
||||||
|
"Step to the next form: take the stepper's `next' restart."
|
||||||
|
(interactive)
|
||||||
|
(flan-cnr--take-named "next"))
|
||||||
|
|
||||||
|
(defun flan-cnr-continue ()
|
||||||
|
"Take the innermost `continue' restart.
|
||||||
|
At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes."
|
||||||
|
(interactive)
|
||||||
|
(flan-cnr--take-named "continue"))
|
||||||
|
|
||||||
|
(defun flan-cnr--step-site (state)
|
||||||
|
"Where a stepper's STATE stopped: the first frame that is not the prelude's."
|
||||||
|
(seq-some (lambda (fr)
|
||||||
|
(and (not (flan-cnr--prelude-frame-p fr))
|
||||||
|
(plist-get fr :loc)))
|
||||||
|
(plist-get state :stack)))
|
||||||
|
|
||||||
|
(defun flan-cnr--show-step-site (state)
|
||||||
|
"At a stepper's stop, show the form about to run in its source, highlighted.
|
||||||
|
The break buffer keeps the selection; the source is shown beside it."
|
||||||
|
(let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state))))
|
||||||
|
(when loc
|
||||||
|
(ignore-errors
|
||||||
|
(save-selected-window
|
||||||
|
(with-current-buffer (flan-visit-loc loc "the step")
|
||||||
|
(pulse-momentary-highlight-region
|
||||||
|
(point) (save-excursion (ignore-errors (forward-sexp)) (point)))))))))
|
||||||
|
|
||||||
(defun flan-cnr-refresh ()
|
(defun flan-cnr-refresh ()
|
||||||
"Ask the program again what it is offering."
|
"Ask the program again what it is offering."
|
||||||
(interactive)
|
(interactive)
|
||||||
@ -920,6 +968,9 @@ anyone who would rather TAB always moved."
|
|||||||
;; SLIME's `e': evaluate in the frame at point.
|
;; SLIME's `e': evaluate in the frame at point.
|
||||||
(define-key map "e" #'flan-cnr-eval-in-frame)
|
(define-key map "e" #'flan-cnr-eval-in-frame)
|
||||||
(define-key map "a" #'flan-cnr-abort)
|
(define-key map "a" #'flan-cnr-abort)
|
||||||
|
;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves).
|
||||||
|
(define-key map "s" #'flan-cnr-step)
|
||||||
|
(define-key map "c" #'flan-cnr-continue)
|
||||||
(define-key map "g" #'flan-cnr-refresh)
|
(define-key map "g" #'flan-cnr-refresh)
|
||||||
(define-key map "q" #'quit-window)
|
(define-key map "q" #'quit-window)
|
||||||
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
|
;; Numbered, as SBCL's are, and for SBCL's reason: the names are not
|
||||||
@ -1162,6 +1213,7 @@ walk from a running program."
|
|||||||
;; the program running again: see `flan--forget-break-stack'.
|
;; the program running again: see `flan--forget-break-stack'.
|
||||||
(setq next-error-last-buffer buf))
|
(setq next-error-last-buffer buf))
|
||||||
(pop-to-buffer buf)
|
(pop-to-buffer buf)
|
||||||
|
(flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf))
|
||||||
buf)))
|
buf)))
|
||||||
|
|
||||||
(provide 'flan-cnr)
|
(provide 'flan-cnr)
|
||||||
|
|||||||
@ -87,6 +87,7 @@
|
|||||||
;; wiring they need.
|
;; wiring they need.
|
||||||
(autoload 'flan-inspect "flan-inspect" nil t)
|
(autoload 'flan-inspect "flan-inspect" nil t)
|
||||||
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
||||||
|
(autoload 'flan-step-defun "flan" nil t)
|
||||||
(autoload 'flan-doc "flan" nil t)
|
(autoload 'flan-doc "flan" nil t)
|
||||||
(autoload 'flan "flan" nil t)
|
(autoload 'flan "flan" nil t)
|
||||||
(autoload 'flan-quit "flan" nil t)
|
(autoload 'flan-quit "flan" nil t)
|
||||||
@ -448,6 +449,8 @@ For `syntax-propertize-function'."
|
|||||||
;; reads as the client being broken rather than as the key being free.
|
;; reads as the client being broken rather than as the key being free.
|
||||||
(define-key map (kbd "C-M-x") #'flan-eval-defun)
|
(define-key map (kbd "C-M-x") #'flan-eval-defun)
|
||||||
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
|
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
|
||||||
|
;; The stepper: the defn at point, installed to stop before each form.
|
||||||
|
(define-key map (kbd "C-c C-s") #'flan-step-defun)
|
||||||
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
|
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
|
||||||
(define-key map (kbd "C-c C-z") #'flan-connect)
|
(define-key map (kbd "C-c C-z") #'flan-connect)
|
||||||
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
||||||
|
|||||||
@ -2590,7 +2590,7 @@ signature, listed in %s"
|
|||||||
(user-error "flan: %s%s" (or msg "rejected")
|
(user-error "flan: %s%s" (or msg "rejected")
|
||||||
(if loc (format " (%s)" loc) "")))))
|
(if loc (format " (%s)" loc) "")))))
|
||||||
|
|
||||||
(defun flan--eval (code what &optional start end pause)
|
(defun flan--eval (code what &optional start end pause step)
|
||||||
"Send CODE to the running program. WHAT names it for the echo area.
|
"Send CODE to the running program. WHAT names it for the echo area.
|
||||||
START and END, when given, are the region it came from, flashed on success.
|
START and END, when given, are the region it came from, flashed on success.
|
||||||
PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the
|
PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the
|
||||||
@ -2605,7 +2605,8 @@ breakpoint is marked from the editor, without editing the buffer\"."
|
|||||||
(append
|
(append
|
||||||
(list :op "eval" :code code :file (or buffer-file-name "<buffer>"))
|
(list :op "eval" :code code :file (or buffer-file-name "<buffer>"))
|
||||||
(when pause
|
(when pause
|
||||||
(list :pause (flan--wire-position (car pause))))))))
|
(list :pause (flan--wire-position (car pause))))
|
||||||
|
(when step (list :step t))))))
|
||||||
;; END as the place a value could go. Every caller of this sends a
|
;; END as the place a value could go. Every caller of this sends a
|
||||||
;; declaration and declarations have no value, so this is the path that
|
;; declaration and declarations have no value, so this is the path that
|
||||||
;; stays open rather than one anybody takes today.
|
;; stays open rather than one anybody takes today.
|
||||||
@ -2632,6 +2633,10 @@ breakpoint is marked from the editor, without editing the buffer\"."
|
|||||||
(cond
|
(cond
|
||||||
((and pause (plist-get reply :pause))
|
((and pause (plist-get reply :pause))
|
||||||
(flan--show-pause (car pause) (cdr pause)))
|
(flan--show-pause (car pause) (cdr pause)))
|
||||||
|
;; An instrumented defn is marked whole, as a pause mark is, and an
|
||||||
|
;; ordinary C-c C-c of it takes the mark down with the instrumentation.
|
||||||
|
((and step start end (plist-get reply :step))
|
||||||
|
(flan--show-pause start end))
|
||||||
((and start end) (flan-clear-pause start end)))
|
((and start end) (flan-clear-pause start end)))
|
||||||
reply))
|
reply))
|
||||||
|
|
||||||
@ -2913,6 +2918,20 @@ declaration for it to live in."
|
|||||||
;; `flan--report' signals on a rejection.
|
;; `flan--report' signals on a rejection.
|
||||||
(pulse-momentary-highlight-region (car b) end))))))
|
(pulse-momentary-highlight-region (car b) end))))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-step-defun ()
|
||||||
|
"Install the defn at point so that a call stops before each form of its body.
|
||||||
|
A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the
|
||||||
|
program and its clock frozen, and the break buffer shows the form about to
|
||||||
|
run. There `s' steps to the next form and `c' runs the rest of the call; the
|
||||||
|
next call steps again. `C-c C-c' on the defn installs it plain."
|
||||||
|
(interactive)
|
||||||
|
(let* ((b (flan--defun-bounds))
|
||||||
|
(head (and (< (car b) (cdr b))
|
||||||
|
(flan--declaration-head-at (car b) flan--defun-heads))))
|
||||||
|
(unless head (user-error "flan: no defn at point to step through"))
|
||||||
|
(flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t)))
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(defun flan-eval-buffer ()
|
(defun flan-eval-buffer ()
|
||||||
"Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER.
|
"Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER.
|
||||||
|
|||||||
@ -1507,6 +1507,60 @@ would be overwritten. Look again and re-do the edit")
|
|||||||
(test-flan--check "`e' is the break buffer's own key"
|
(test-flan--check "`e' is the break buffer's own key"
|
||||||
(eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame))))
|
(eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame))))
|
||||||
|
|
||||||
|
;; The stepper's stop: said as a step, the prelude's own frame hidden, and
|
||||||
|
;; `s' and `c' take its `next' and `continue' by index.
|
||||||
|
(let* ((asked nil)
|
||||||
|
(flan-cnr-request-function
|
||||||
|
(lambda (form) (push form asked) '(:status "ok"))))
|
||||||
|
(with-current-buffer (test-flan--cnr
|
||||||
|
(list :condition "StepPoint"
|
||||||
|
:restarts '("next" "continue" "continue")
|
||||||
|
:stack (list (list :fn "step-point" :loc "<prelude>:250:3")
|
||||||
|
(list :fn "step" :loc "/s.flan:1:19"))))
|
||||||
|
(let ((text (buffer-string)))
|
||||||
|
(test-flan--check "a step's headline says it is stepping"
|
||||||
|
(string-match-p "stepping: stopped before the form" text))
|
||||||
|
(test-flan--check "and the prelude's step-point frame is hidden"
|
||||||
|
(not (string-match-p "step-point" text))))
|
||||||
|
(test-flan--check "the step site is the stepped frame's location"
|
||||||
|
(equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19"))
|
||||||
|
(save-window-excursion (flan-cnr-step))
|
||||||
|
(test-flan--check "`s' takes next"
|
||||||
|
(and (equal (plist-get (car asked) :op) "restart-at")
|
||||||
|
(equal (plist-get (car asked) :name) "next")
|
||||||
|
(= 0 (plist-get (car asked) :index)))))
|
||||||
|
(with-current-buffer (test-flan--cnr
|
||||||
|
(list :condition "StepPoint"
|
||||||
|
:restarts '("next" "continue" "continue")))
|
||||||
|
(save-window-excursion (flan-cnr-continue))
|
||||||
|
(test-flan--check "`c' takes the innermost continue"
|
||||||
|
(and (equal (plist-get (car asked) :name) "continue")
|
||||||
|
(= 1 (plist-get (car asked) :index)))))
|
||||||
|
(test-flan--check "`s' and `c' are the break buffer's own keys"
|
||||||
|
(and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step)
|
||||||
|
(eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue))))
|
||||||
|
|
||||||
|
;; C-c C-s sends the defn at point for stepping and marks it.
|
||||||
|
(let ((sent nil))
|
||||||
|
(with-temp-buffer
|
||||||
|
(flan-mode)
|
||||||
|
(insert "(defn step [] i64\n (set ticks 1)\n ticks)\n")
|
||||||
|
(goto-char (point-min))
|
||||||
|
(forward-line 1)
|
||||||
|
(cl-letf (((symbol-function 'flan--request)
|
||||||
|
(lambda (form) (setq sent form)
|
||||||
|
'(:status "ok" :fns ("step") :names ("step") :step t)))
|
||||||
|
((symbol-function 'flan-refresh-defs) #'ignore))
|
||||||
|
(flan-step-defun))
|
||||||
|
(test-flan--check "C-c C-s sends the defn with :step"
|
||||||
|
(and (equal (plist-get sent :op) "eval")
|
||||||
|
(plist-get sent :step)
|
||||||
|
(string-prefix-p "(defn step" (plist-get sent :code))))
|
||||||
|
(test-flan--check "and marks it as instrumented"
|
||||||
|
(flan--pause-overlays))
|
||||||
|
(test-flan--check "C-c C-s is flan-mode's key for it"
|
||||||
|
(eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun))))
|
||||||
|
|
||||||
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
||||||
;; empty buffer.
|
;; empty buffer.
|
||||||
;; The layout without the values: what a `layout' op alone would buy. The
|
;; The layout without the values: what a `layout' op alone would buy. The
|
||||||
|
|||||||
65
lib/ast.ml
65
lib/ast.ml
@ -481,6 +481,71 @@ let map_children f (e : expr) : expr =
|
|||||||
|
|
||||||
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
|
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
|
||||||
|
|
||||||
|
(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a
|
||||||
|
call stops before each form of its body, at any depth of body: the forms of
|
||||||
|
a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not
|
||||||
|
inside an argument, an [fn] or a handler clause, which are not forms a
|
||||||
|
person reads as steps, and the last two are functions of their own. [None]
|
||||||
|
when there is no [defn] to instrument.
|
||||||
|
|
||||||
|
A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a
|
||||||
|
[restart-case], so the break loop takes it as it takes [(pause)], with the
|
||||||
|
game loop and its clock frozen. It answers whether to go on stepping: its
|
||||||
|
[next] restart says yes and its [continue] says no, and the answer is kept
|
||||||
|
in a local of the call, [flan~step], so [continue] runs the rest of this
|
||||||
|
call and the next call steps again. [~] cannot occur in a source symbol, so
|
||||||
|
the local is visibly the compiler's and hidden from the locals listing. *)
|
||||||
|
let step_flag = "flan~step"
|
||||||
|
|
||||||
|
let step_point loc =
|
||||||
|
let v = { e = Var step_flag; loc } in
|
||||||
|
{ e =
|
||||||
|
If (v,
|
||||||
|
{ e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc });
|
||||||
|
loc },
|
||||||
|
None);
|
||||||
|
loc }
|
||||||
|
|
||||||
|
let rec step_body (es : expr list) : expr list =
|
||||||
|
List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es
|
||||||
|
|
||||||
|
and step_expr (e : expr) : expr =
|
||||||
|
let branch (x : expr) =
|
||||||
|
match x.e with
|
||||||
|
| Do _ -> step_expr x
|
||||||
|
| _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc }
|
||||||
|
in
|
||||||
|
match e.e with
|
||||||
|
| Do es -> { e with e = Do (step_body es) }
|
||||||
|
| Let (bs, es) -> { e with e = Let (bs, step_body es) }
|
||||||
|
| If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) }
|
||||||
|
| While (l, c, es) -> { e with e = While (l, c, step_body es) }
|
||||||
|
| Loop (bs, es) -> { e with e = Loop (bs, step_body es) }
|
||||||
|
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) }
|
||||||
|
| Match (sc, arms) ->
|
||||||
|
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) }
|
||||||
|
| _ -> e
|
||||||
|
|
||||||
|
let instrument_step (ds : decl list) : decl list option =
|
||||||
|
let hit = ref false in
|
||||||
|
let ds =
|
||||||
|
List.map
|
||||||
|
(fun (d : decl) ->
|
||||||
|
match d.d with
|
||||||
|
| Defn f ->
|
||||||
|
hit := true;
|
||||||
|
let on =
|
||||||
|
{ bname = step_flag; bty = None;
|
||||||
|
bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc }
|
||||||
|
in
|
||||||
|
{ d with
|
||||||
|
d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody);
|
||||||
|
loc = d.dloc } ] } }
|
||||||
|
| _ -> d)
|
||||||
|
ds
|
||||||
|
in
|
||||||
|
if !hit then Some ds else None
|
||||||
|
|
||||||
(* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever
|
(* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever
|
||||||
starts at that position, or [None] when nothing does.
|
starts at that position, or [None] when nothing does.
|
||||||
|
|
||||||
|
|||||||
13
lib/dev.ml
13
lib/dev.ml
@ -1022,7 +1022,7 @@ let errors_reply (ds : Loc.diag list) =
|
|||||||
String.sub e 0 (String.length e - 1)
|
String.sub e 0 (String.length e - 1)
|
||||||
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
^ " " ^ String.concat " " (errors_field ds) ^ ")"
|
||||||
|
|
||||||
let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
|
||||||
let now = liveness t in
|
let now = liveness t in
|
||||||
let parked_now = now = Parked in
|
let parked_now = now = Parked in
|
||||||
(* A park that is over takes its note with it: the long sentence below is
|
(* A park that is over takes its note with it: the long sentence below is
|
||||||
@ -1046,7 +1046,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
|||||||
if now = Gone then error gone
|
if now = Gone then error gone
|
||||||
else
|
else
|
||||||
match
|
match
|
||||||
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
|
Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now)
|
||||||
t.session code
|
t.session code
|
||||||
with
|
with
|
||||||
| c when not c.Session.installs ->
|
| c when not c.Session.installs ->
|
||||||
@ -1109,6 +1109,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
|
|||||||
| Some (l, c) ->
|
| Some (l, c) ->
|
||||||
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
|
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
|
||||||
| None -> [])
|
| None -> [])
|
||||||
|
@ (if step then [ ":step t" ] else [])
|
||||||
@ install_note t ~parked:parked_now
|
@ install_note t ~parked:parked_now
|
||||||
@ unpolled_note t ~parked:parked_now
|
@ unpolled_note t ~parked:parked_now
|
||||||
@ extra)
|
@ extra)
|
||||||
@ -4399,7 +4400,13 @@ let handle t req =
|
|||||||
let origin =
|
let origin =
|
||||||
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
match Wire.string_field req "file" with Some f -> f | None -> "<editor>"
|
||||||
in
|
in
|
||||||
eval t ~code ~origin ~pause:(Wire.pos_field req "pause")
|
(* [:step t] instruments every defn sent for the stepper. *)
|
||||||
|
let step =
|
||||||
|
match Wire.field req "step" with
|
||||||
|
| Some { Form.v = Form.Sym "nil"; _ } | None -> false
|
||||||
|
| Some _ -> true
|
||||||
|
in
|
||||||
|
eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step
|
||||||
| None -> error "eval needs :code")
|
| None -> error "eval needs :code")
|
||||||
| Some "eval-expr" ->
|
| Some "eval-expr" ->
|
||||||
(match Wire.string_field req "code" with
|
(match Wire.string_field req "code" with
|
||||||
|
|||||||
@ -240,6 +240,18 @@ let source = {flan|
|
|||||||
(defn pause [] ()
|
(defn pause [] ()
|
||||||
(restart-case (error (Pause {}))
|
(restart-case (error (Pause {}))
|
||||||
(continue [] (do))))
|
(continue [] (do))))
|
||||||
|
;; The stepper's stop, which C-c C-s puts before each form of a defn's body
|
||||||
|
;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping
|
||||||
|
;; and continue runs the rest of the call, and the instrumented body keeps
|
||||||
|
;; that answer in a local of its own. Like Pause it is not under Error.
|
||||||
|
;; Named so a program's own step or Step is not what the instrumented body
|
||||||
|
;; calls.
|
||||||
|
(defstruct StepPoint [])
|
||||||
|
|
||||||
|
(defn step-point [] bool
|
||||||
|
(restart-case (error (StepPoint {}))
|
||||||
|
(next [] :report "stop at the next form" true)
|
||||||
|
(continue [] :report "run the rest of this call" false)))
|
||||||
|
|
||||||
;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a
|
;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a
|
||||||
;; regression test if the sequence is byte-identical on native and wasm32
|
;; regression test if the sequence is byte-identical on native and wasm32
|
||||||
|
|||||||
@ -787,7 +787,7 @@ let rerun t = t.live <- SM.empty
|
|||||||
file an [(import ...)] in them is resolved against, the session's own when
|
file an [(import ...)] in them is resolved against, the session's own when
|
||||||
absent: a file loaded from another directory names its packages from
|
absent: a file loaded from another directory names its packages from
|
||||||
there. *)
|
there. *)
|
||||||
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : change =
|
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change =
|
||||||
let forms =
|
let forms =
|
||||||
match forms with Some f -> f | None -> Reader.read_all ~file:origin src
|
match forms with Some f -> f | None -> Reader.read_all ~file:origin src
|
||||||
in
|
in
|
||||||
@ -877,6 +877,15 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
|
|||||||
fail loc "nothing to pause at line %d, column %d of the form sent"
|
fail loc "nothing to pause at line %d, column %d of the form sent"
|
||||||
line col)
|
line col)
|
||||||
in
|
in
|
||||||
|
(* [step]: every defn sent stops before each form of its body — see
|
||||||
|
[Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *)
|
||||||
|
let incoming =
|
||||||
|
if not step then incoming
|
||||||
|
else
|
||||||
|
match Ast.instrument_step incoming with
|
||||||
|
| Some ds -> ds
|
||||||
|
| None -> fail loc "there is no defn in the form sent to step through"
|
||||||
|
in
|
||||||
(* A method declares a name of its own — that is what makes evaluating one
|
(* A method declares a name of its own — that is what makes evaluating one
|
||||||
twice a replacement and evaluating a new one an append, through the same
|
twice a replacement and evaluating a new one an append, through the same
|
||||||
kept/added logic every other declaration goes through. But no function is
|
kept/added logic every other declaration goes through. But no function is
|
||||||
@ -1504,6 +1513,15 @@ let shown_names (fn : Tast.fn) : string option array =
|
|||||||
Array.init n (fun i ->
|
Array.init n (fun i ->
|
||||||
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None)
|
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None)
|
||||||
in
|
in
|
||||||
|
(* A name the compiler gave a local of its own, such as the stepper's
|
||||||
|
[flan~step], is hidden like an unnamed slot: [~] cannot be typed. *)
|
||||||
|
let raw =
|
||||||
|
Array.map
|
||||||
|
(function
|
||||||
|
| Some n when String.starts_with ~prefix:"flan~" n -> None
|
||||||
|
| x -> x)
|
||||||
|
raw
|
||||||
|
in
|
||||||
let stripped = Array.map (Option.map strip_rebind) raw in
|
let stripped = Array.map (Option.map strip_rebind) raw in
|
||||||
let count name =
|
let count name =
|
||||||
Array.fold_left
|
Array.fold_left
|
||||||
|
|||||||
130
test/test_dev.ml
130
test/test_dev.ml
@ -8759,6 +8759,136 @@ let () =
|
|||||||
hook_block ~llvm:false;
|
hook_block ~llvm:false;
|
||||||
hook_block ~llvm:true;
|
hook_block ~llvm:true;
|
||||||
|
|
||||||
|
(* ── The stepper ─────────────────────────────────────────────────
|
||||||
|
[dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call
|
||||||
|
stops before each form of its body: first the (set ...), then, after
|
||||||
|
[next], the [ticks] it answers. [continue] runs the rest of the call,
|
||||||
|
and the next call steps again. A plain evaluation takes it out. Under
|
||||||
|
both backends, each with its own daemon. *)
|
||||||
|
let stepper ~llvm =
|
||||||
|
let what = if llvm then "llvm " else "x86 " in
|
||||||
|
let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in
|
||||||
|
(try Sys.remove ssock with Sys_error _ -> ());
|
||||||
|
let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||||
|
let spid =
|
||||||
|
Unix.create_process flan
|
||||||
|
(Array.append
|
||||||
|
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |]
|
||||||
|
(if llvm then [| "--llvm" |] else [||]))
|
||||||
|
Unix.stdin sfd Unix.stderr
|
||||||
|
in
|
||||||
|
Unix.close sfd;
|
||||||
|
if not (listening ~pid:spid ssock) then
|
||||||
|
fail "%sstepper daemon %s" what !listen_why
|
||||||
|
else begin
|
||||||
|
let c = connect ssock in
|
||||||
|
let ask = request c in
|
||||||
|
let stopped r =
|
||||||
|
match Wire.field r "stopped" with
|
||||||
|
| Some { Form.v = Form.Sym "t"; _ } -> true
|
||||||
|
| _ -> false
|
||||||
|
in
|
||||||
|
let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in
|
||||||
|
let col sub =
|
||||||
|
let n = String.length sub in
|
||||||
|
let rec find i =
|
||||||
|
if String.equal (String.sub body i n) sub then i + 1 else find (i + 1)
|
||||||
|
in
|
||||||
|
find 0
|
||||||
|
in
|
||||||
|
(* Where the stepped frame is: the frame of [step], whose location is
|
||||||
|
the step point's, which is the form about to run. *)
|
||||||
|
let at () =
|
||||||
|
match Wire.field (ask "(:op \"backtrace\")") "frames" with
|
||||||
|
| Some { Form.v = Form.List l; _ } ->
|
||||||
|
List.find_map
|
||||||
|
(fun (f : Form.t) ->
|
||||||
|
match f.Form.v with
|
||||||
|
| Form.List ({ Form.v = Form.Str "step"; _ }
|
||||||
|
:: { Form.v = Form.Str loc; _ } :: _) -> Some loc
|
||||||
|
| _ -> None)
|
||||||
|
l
|
||||||
|
| _ -> None
|
||||||
|
in
|
||||||
|
let stops_at sub =
|
||||||
|
let want = Printf.sprintf ":1:%d" (col sub) in
|
||||||
|
await (fun () ->
|
||||||
|
stopped (ask "(:op \"describe\")")
|
||||||
|
&& (match at () with Some l -> contains_sub l want | None -> false))
|
||||||
|
in
|
||||||
|
let r =
|
||||||
|
ask
|
||||||
|
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)"
|
||||||
|
(Wire.quote body))
|
||||||
|
in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "%sinstrumenting for the stepper: %s" what
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||||
|
else begin
|
||||||
|
if Wire.field r "step" = None then
|
||||||
|
fail "%san instrumented defn did not echo :step" what;
|
||||||
|
if not (stops_at "(set ticks") then
|
||||||
|
fail "%sthe stepper did not stop before the first form (at %s)" what
|
||||||
|
(Option.value ~default:"<none>" (at ()))
|
||||||
|
else begin
|
||||||
|
(match Wire.string_field (ask "(:op \"describe\")") "condition" with
|
||||||
|
| Some "StepPoint" -> ()
|
||||||
|
| c -> fail "%sa step stopped on %s" what (Option.value ~default:"<none>" c));
|
||||||
|
(* The stepper's own local is not one of the frame's. *)
|
||||||
|
let fr = ask "(:op \"locals\" :frame 1)" in
|
||||||
|
(match Wire.string_field fr "frame" with
|
||||||
|
| Some "step" ->
|
||||||
|
(match Wire.field fr "locals" with
|
||||||
|
| Some { Form.v = Form.List []; _ } | None -> ()
|
||||||
|
| _ -> fail "%sthe stepper's flag is listed as a local" what)
|
||||||
|
| f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"<none>" f));
|
||||||
|
let r = ask "(:op \"restart\" :name \"next\")" in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "%snext at a step: %s" what
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||||
|
if not (stops_at "ticks)") then
|
||||||
|
fail "%snext did not stop before the second form (at %s)" what
|
||||||
|
(Option.value ~default:"<none>" (at ()));
|
||||||
|
let r = ask "(:op \"restart\" :name \"continue\")" in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "%scontinue at a step: %s" what
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||||
|
(* The next call, 5ms on, steps again from the top. *)
|
||||||
|
if not (stops_at "(set ticks") then
|
||||||
|
fail "%sthe next call did not step again" what;
|
||||||
|
let r =
|
||||||
|
ask
|
||||||
|
(Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")"
|
||||||
|
(Wire.quote body))
|
||||||
|
in
|
||||||
|
if status r <> "ok" then
|
||||||
|
fail "%sinstalling the plain defn: %s" what
|
||||||
|
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||||
|
ignore (ask "(:op \"restart\" :name \"continue\")");
|
||||||
|
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
||||||
|
fail "%sthe program did not resume from the last step" what;
|
||||||
|
let deadline = Unix.gettimeofday () +. 0.5 in
|
||||||
|
let rec run_on () =
|
||||||
|
if Unix.gettimeofday () > deadline then ()
|
||||||
|
else if stopped (ask "(:op \"describe\")") then
|
||||||
|
fail "%sthe plain defn still steps" what
|
||||||
|
else begin
|
||||||
|
ignore (Unix.select [] [] [] 0.01);
|
||||||
|
run_on ()
|
||||||
|
end
|
||||||
|
in
|
||||||
|
run_on ()
|
||||||
|
end
|
||||||
|
end;
|
||||||
|
(try Unix.close c with Unix.Unix_error _ -> ())
|
||||||
|
end;
|
||||||
|
(try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||||
|
(try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ());
|
||||||
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ]
|
||||||
|
in
|
||||||
|
stepper ~llvm:false;
|
||||||
|
stepper ~llvm:true;
|
||||||
|
|
||||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
||||||
[ sock; out; bsock; bout ];
|
[ sock; out; bsock; bout ];
|
||||||
Test_support.report ~label:"dev" ()
|
Test_support.report ~label:"dev" ()
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user