diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 609c6ba..b1a0375 100644 --- a/simulator-structs.rkt +++ b/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) diff --git a/simulator.rkt b/simulator.rkt index 381c519..8c4b99c 100644 --- a/simulator.rkt +++ b/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)) - (make-machine v proc env control pc text)])) + [(struct machine (val 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)) - (make-machine val v env control pc text)])) + [(struct machine (val proc 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)) - (make-machine val proc (cons v env) control pc text)])) + [(struct machine (val proc env control pc text stack-size)) + (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)) - (make-machine val proc (append vs env) control pc text)])) + [(struct machine (val proc env control pc text stack-size)) + (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)) - (make-machine val proc (list-replace env i v) 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 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)) - (make-machine val proc env (cons (make-frame l) 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 + stack-size)])) (: control-pop (machine -> (values machine Symbol))) (define (control-pop m) (match m - [(struct machine (val proc env control pc text)) - (values (make-machine val proc env (rest control) pc text) + [(struct machine (val proc env control pc text stack-size)) + (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)) - (make-machine val proc env control (add1 pc) text)])) + [(struct machine (val proc env control pc text stack-size)) + (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)) - (make-machine val proc env control (vector-find text l) text)])) + [(struct machine (val proc env control pc text stack-size)) + (make-machine val proc env control (vector-find text l) text stack-size)])) (: vector-find (All (A) (Vectorof A) A -> Natural)) diff --git a/test-compiler.rkt b/test-compiler.rkt index 586688e..0f140c5 100644 --- a/test-compiler.rkt +++ b/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)) diff --git a/test-simulator.rkt b/test-simulator.rkt index 592cb7d..043a00f 100644 --- a/test-simulator.rkt +++ b/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))