Trying to augment the simulator to keep track of the stack size

simulator-structs.rkt

@@ -22,6 +22,9 @@
 
                          [pc : Natural]                  ;; program counter
                          [text : (Vectorof Statement)]   ;; text of the program
+
+                         ;; other metrics for debugging
+                         [stack-size : Natural]
                          )
   #:transparent)
 

simulator.rkt

@@ -20,7 +20,7 @@
 
 (: new-machine ((Listof Statement) -> machine))
 (define (new-machine program-text)
-  (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text)))
+  (make-machine (make-undefined) (make-undefined) '() '() 0 (list->vector program-text) 0))
 
 
 (: can-step? (machine -> Boolean))
@@ -339,11 +339,18 @@
     [else
      (error 'ensure-toplevel)]))
 
+(: ensure-natural (Integer -> Natural))
+(define (ensure-natural x)
+  (if (>= x 0)
+      x
+      (error 'ensure-natural)))
+
 
 (: current-instruction (machine -> Statement))
 (define (current-instruction m)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text
+                          stack-size))
      (vector-ref text pc)]))
 
   
@@ -351,39 +358,43 @@
 (: val-update (machine SlotValue -> machine))
 (define (val-update m v)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text
-     (make-machine v proc env control pc text)]))
+                          stack-size))
+     (make-machine v proc env control pc text stack-size)]))
 
 (: proc-update (machine SlotValue -> machine))
 (define (proc-update m v)
     (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text
-     (make-machine val v env control pc text)]))
+                          stack-size))
+     (make-machine val v env control pc text stack-size)]))
 
 (: env-push (machine SlotValue -> machine))
 (define (env-push m v)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc (cons v env) control pc text)]))
+     (make-machine val proc (cons v env) control pc text
+                   (add1 stack-size))]))
 
 (: env-push-many (machine (Listof SlotValue) -> machine))
 (define (env-push-many m vs)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc (append vs env) control pc text)]))
+     (make-machine val proc (append vs env) control pc text
+                   (+ stack-size (length vs)))]))
 
 
 (: env-ref (machine Natural -> SlotValue))
 (define (env-ref m i)  
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
      (list-ref env i)]))
 
 (: env-mutate (machine Natural SlotValue -> machine))
 (define (env-mutate m i v)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc (list-replace env i v) control pc text)]))
+     (make-machine val proc (list-replace env i v) control pc text stack-size)]))
 
 (: list-replace (All (A) (Listof A) Natural A -> (Listof A)))
 (define (list-replace l i v)
@@ -398,39 +409,41 @@
 (: env-pop (machine Natural Natural -> machine))
 (define (env-pop m n skip)     
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
      (make-machine val proc (append (take env skip)
                                     (drop env (+ skip n)))
-                   control pc text)]))
+                   control pc text
+                   (ensure-natural (- stack-size n)))]))
 
 
 (: control-push (machine Symbol -> machine))
 (define (control-push m l)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc env (cons (make-frame l) control) pc text)]))
+     (make-machine val proc env (cons (make-frame l) control) pc text
+                   stack-size)]))
 
 
 (: control-pop (machine -> (values machine Symbol)))
 (define (control-pop m)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (values (make-machine val proc env (rest control) pc text)
+     (values (make-machine val proc env (rest control) pc text stack-size)
              (frame-return (first control)))]))
 
 (: increment-pc (machine -> machine))
 (define (increment-pc m)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc env control (add1 pc) text)]))
+     (make-machine val proc env control (add1 pc) text stack-size)]))
 
 
 (: jump (machine Symbol -> machine))
 ;; Jumps directly to the instruction at the given label.
 (define (jump m l)
   (match m
-    [(struct machine (val proc env control pc text))
+    [(struct machine (val proc env control pc text stack-size))
-     (make-machine val proc env control (vector-find text l) text)]))
+     (make-machine val proc env control (vector-find text l) text stack-size)]))
 
 
 (: vector-find (All (A) (Vectorof A) A -> Natural))

test-compiler.rkt

@@ -24,7 +24,7 @@
              (unless (equal? actual exp)
                (raise-syntax-error #f (format "Expected ~s, got ~s" exp actual)
                                    #'stx))
-             (unless (= (length (machine-env a-machine)) 1)
+             (unless (= (machine-stack-size a-machine) 1)
                (raise-syntax-error #f (format "Stack is not back to the prefix as expected!")
                                    #'stx))
              (printf "ok. ~s steps.\n\n" num-steps)))))]))
@@ -32,7 +32,7 @@
 ;; test, and expect an error
 (define-syntax (test/exn stx)
   (syntax-case stx ()
-    [(_ code)
+    [(_ code options ...)
      (with-syntax ([stx stx])
        (syntax/loc #'stx
          (begin
@@ -41,7 +41,7 @@
              (with-handlers ([exn:fail? (lambda (exn)
                                           (printf "ok\n\n")
                                           (return))])
-               (run (new-machine (run-compiler 'code))))
+               (run (new-machine (run-compiler 'code)) options ...))
              (raise-syntax-error #f (format "Expected an exception")
                                  #'stx)))))]))
 
@@ -60,7 +60,7 @@
                 (length (machine-env m))
                 (current-instruction m))))
     (when stack-limit
-      (when (stack-overflow? (machine-env m) stack-limit)
+      (when (> (machine-stack-size m) stack-limit)
         (error 'run "Stack overflow")))
 
     (cond
@@ -69,15 +69,6 @@
       [else
        (values m steps)])))
 
-(define (stack-overflow? l n)
-  (cond
-    [(empty? l)
-     #f]
-    [(= n 0)
-     #t]
-    [else
-     (stack-overflow? (rest l) (sub1 n))]))
-
 
 ;; Atomic expressions
 (test 42 42)
@@ -201,6 +192,7 @@
 
 
 
+
 ;; Tail calling behavior: watch that the stack never grows beyond 8.
 (test (begin (define (f x acc)
                  (if (= x 0)
@@ -213,7 +205,22 @@
                         (* x (f (sub1 x)))))])
         (f 1000))
       #:stack-limit 8)
-      
+
+;; And from experimental testing, anything below 7 will break.
+(test/exn (begin (define (f x acc)
+                   (if (= x 0)
+                       acc
+                       (f (sub1 x) (* x acc))))
+                 (f 1000 1))
+          (letrec ([f (lambda (x)
+                        (if (= x 0)
+                            1
+                            (* x (f (sub1 x)))))])
+            (f 1000))
+          #:stack-limit 7)
+
+
+
 
 ;; tak test
 (test (begin (define (tak x y z)
@@ -226,16 +233,6 @@
       7)
       
 
-(test (begin (define (tak x y z)
-               (if (>= y x)
-                   z
-                   (tak (tak (- x 1) y z)
-                        (tak (- y 1) z x)
-                        (tak (- z 1) x y))))
-             (tak 18 12 6))
-      7
-      #:stack-limit 120)
-
 
 
 ;(simulate (compile (parse '42) 'val 'next))

test-simulator.rkt

@@ -282,8 +282,8 @@
                      '() 
                      0 
                      (list->vector `(,(make-PerformStatement (make-InstallClosureValues!))
-                                     procedure-entry
+                                     procedure-entry))
-                                     )))])
+                     0)])
   (test (machine-env (run m))
         ;; Check that the environment has installed the expected closure values.
         (list 1 2 3 true false)))
@@ -296,7 +296,8 @@
                      (list true false) ;; existing environment holds true, false
                      '() 
                      0 
-                     (list->vector `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)))))])
+                     (list->vector `(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
+                     0)])
   (test (machine-val (run m))
         'procedure-entry))