Add stack size computation to disassembler

* module/system/vm/disassembler.scm (define-stack-effect-parser)
  (stack-effect-parsers, instruction-stack-size-after): New stack size
  facility.
  (define-clobber-parser, clobber-parsers, instruction-slot-clobbers):
  Take incoming and outgoing stack sizes as arguments to interpret
  SP-relative clobbers.

* module/system/vm/frame.scm (compute-frame-sizes): New helper that
  computes frame sizes for each position in a function.
  (compute-killv): Adapt to compute the clobbered set given the computed
  frame sizes.

module/system/vm/disassembler.scm

@@ -39,6 +39,7 @@
             instruction-length
             instruction-has-fallthrough?
             instruction-relative-jump-targets
+            instruction-stack-size-after
             instruction-slot-clobbers))
 
 (define-syntax-rule (u32-ref buf n)
@@ -536,15 +537,70 @@ address of that offset."
   (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
     ((vector-ref jump-parsers opcode) code pos)))
 
+(define-syntax define-stack-effect-parser
+  (lambda (x)
+    (define (stack-effect-parser name)
+      (case name
+        ((push)
+         #'(lambda (code pos size) (+ size 1)))
+        ((pop)
+         #'(lambda (code pos size) (- size 1)))
+        ((drop)
+         #'(lambda (code pos size)
+             (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
+               (- size count))))
+        ((alloc-frame reset-frame)
+         #'(lambda (code pos size)
+             (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
+               nlocals)))
+        ((receive)
+         #'(lambda (code pos size)
+             (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
+                                 -8)))
+               nlocals)))
+        ((bind-kwargs)
+         #'(lambda (code pos size)
+             (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
+               ntotal)))
+        ((bind-rest)
+         #'(lambda (code pos size)
+             (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
+               (+ dst 1))))
+        ((assert-nargs-ee/locals)
+         #'(lambda (code pos size)
+             (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
+                                  #xfff))
+                   (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
+               (+ nargs nlocals))))
+        ((call call-label)
+         #'(lambda (code pos size) #f))
+        ((tail-call tail-call-label tail-call/shuffle tail-apply)
+         #'(lambda (code pos size) #f))
+        (else
+         #f)))
+    (syntax-case x ()
+      ((_ name opcode kind word0 word* ...)
+       (let ((parser (stack-effect-parser (syntax->datum #'name))))
+         (if parser
+             #`(vector-set! stack-effect-parsers opcode #,parser)
+             #'(begin)))))))
+
+(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size)))
+(visit-opcodes define-stack-effect-parser)
+
+(define (instruction-stack-size-after code pos size)
+  (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+    ((vector-ref stack-effect-parsers opcode) code pos size)))
+
 (define-syntax define-clobber-parser
   (lambda (x)
     (syntax-case x ()
-      ((_ name opcode kind arg ...)
+      ((_ name opcode kind arg0 arg* ...)
        (case (syntax->datum #'kind)
          ((!)
           (case (syntax->datum #'name)
             ((call call-label)
-             #'(let ((parse (lambda (code pos nslots)
+             #'(let ((parse (lambda (code pos nslots-in nslots-out)
                               (call-with-values
                                   (lambda ()
                                     (disassemble-one code (/ pos 4)))
@@ -552,26 +608,32 @@ address of that offset."
                                   (match elt
                                     ((_ proc . _)
                                      (let lp ((slot (- proc 2)))
-                                       (if (< slot nslots)
+                                       (if (< slot nslots-in)
                                            (cons slot (lp (1+ slot)))
                                            '())))))))))
                  (vector-set! clobber-parsers opcode parse)))
             (else
              #'(begin))))
          ((<-)
-          #'(let ((parse (lambda (code pos nslots)
+          #`(let ((parse (lambda (code pos nslots-in nslots-out)
                            (call-with-values
                                (lambda ()
                                  (disassemble-one code (/ pos 4)))
                              (lambda (len elt)
                                (match elt
-                                 ((_ dst . _) (list dst))))))))
+                                 ((_ dst . _)
+                                  #,(case (syntax->datum #'arg0)
+                                      ((X8_F24 X8_F12_F12)
+                                       #'(list dst))
+                                      (else
+                                       #'(list (- nslots-out 1 dst)))))))))))
               (vector-set! clobber-parsers opcode parse)))
          (else (error "unexpected instruction kind" #'kind)))))))
 
-(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
+(define clobber-parsers
+  (make-vector 256 (lambda (code pos nslots-in nslots-out) '())))
 (visit-opcodes define-clobber-parser)
 
-(define (instruction-slot-clobbers code pos nslots)
+(define (instruction-slot-clobbers code pos nslots-in nslots-out)
   (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
-    ((vector-ref clobber-parsers opcode) code pos nslots)))
+    ((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))

module/system/vm/frame.scm

@@ -25,6 +25,7 @@
   #:use-module (system vm debug)
   #:use-module (system vm disassembler)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (binding-index
@@ -83,6 +84,49 @@
         (lp (1+ n) (+ pos (vector-ref parsed n)))))
     preds))
 
+(define (compute-frame-sizes code parsed initial-size)
+  (let ((in-sizes (make-vector (vector-length parsed) #f))
+        (out-sizes (make-vector (vector-length parsed) #f)))
+    ;; This only computes all possible valid stack sizes if the bytecode
+    ;; is sorted topologically.  Guiles' compiler does this currently,
+    ;; but if that changes we should do a proper pre-order visit.  Of
+    ;; course the bytecode has to be valid too.
+    (define (find-idx n diff)
+      (let lp ((n n) (diff diff))
+        (cond
+         ((negative? diff)
+          (lp (1- n) (+ diff (vector-ref parsed (1- n)))))
+         ((positive? diff)
+          (lp (1+ n) (- diff (vector-ref parsed n))))
+         (else n))))
+    (vector-set! in-sizes 0 initial-size)
+    (let lp ((n 0) (pos 0))
+      (define (offset->idx target)
+        (call-with-values (lambda ()
+                            (if (>= target pos)
+                                (values n pos)
+                                (values 0 0)))
+          (lambda (n pos)
+            (let lp ((n n) (pos pos))
+              (cond
+               ((= pos target) n)
+               ((< pos target) (lp (1+ n) (+ pos (vector-ref parsed n))))
+               (else (error "bad target" target)))))))
+      (when (< n (vector-length parsed))
+        (let* ((in (vector-ref in-sizes n))
+               (out (instruction-stack-size-after code pos in)))
+          (vector-set! out-sizes n out)
+          (when out
+            (when (instruction-has-fallthrough? code pos)
+              (vector-set! in-sizes (1+ n) out))
+            (for-each (lambda (target)
+                        (let ((idx (find-idx n target)))
+                          (when idx
+                            (vector-set! in-sizes idx out))))
+                      (instruction-relative-jump-targets code pos))))
+        (lp (1+ n) (+ pos (vector-ref parsed n)))))
+    (values in-sizes out-sizes)))
+
 (define (compute-genv parsed defs)
   (let ((genv (make-vector (vector-length parsed) '())))
     (define (add-def! pos var)
@@ -118,8 +162,11 @@
     by-slot))
 
 (define (compute-killv code parsed defs)
-  (let ((defs-by-slot (compute-defs-by-slot defs))
+  (let*-values (((defs-by-slot) (compute-defs-by-slot defs))
-        (killv (make-vector (vector-length parsed) #f)))
+                ((initial-frame-size) (vector-length defs-by-slot))
+                ((in-sizes out-sizes)
+                 (compute-frame-sizes code parsed initial-frame-size))
+                ((killv) (make-vector (vector-length parsed) #f)))
     (define (kill-slot! n slot)
       (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
     (let lp ((n 0))
@@ -147,7 +194,8 @@
                     (when (< slot (vector-length defs-by-slot))
                       (kill-slot! n slot)))
                   (instruction-slot-clobbers code pos
-                                             (vector-length defs-by-slot)))
+                                             (vector-ref in-sizes n)
+                                             (vector-ref out-sizes n)))
         (lp (1+ n) (+ pos (vector-ref parsed n)))))
     killv))