suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Danny Yoo 2011-03-08 03:50:01 -05:00
parent 71cfb576fa
commit 5307871a46
4 changed files with 64 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
simulator-structs.rkt
View File

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

59
simulator.rkt
View File

@ -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))

45
test-compiler.rkt
View File

@ -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))

7
test-simulator.rkt
View File

@ -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))