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

adjust gc2's mutator language so that void-producing expressions

Browse Source 
are allowed only in places where the value is discarded
This commit is contained in:
Robby Findler 2013-03-07 07:16:51 -06:00
parent bb17b6a8f6
commit 5c90a7ba83
2 changed files with 101 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/plai/gc2/mutator.rkt
View File

@ -47,6 +47,10 @@
(define-syntax-parameter mutator-tail-call? #t)
(define-syntax-parameter mutator-env-roots empty)
(define-syntax-parameter mutator-assignment-allowed? #t)
(define-syntax-rule (no! e) (syntax-parameterize ([mutator-assignment-allowed? #f]) e))
(define-syntax-rule (yes! e) (syntax-parameterize ([mutator-assignment-allowed? #t]) e))
; Sugar Macros
(define-syntax-rule (->address e) e)
(define-syntax mutator-and
@ -112,7 +116,7 @@
[(_ fe e ...)
(let ([tmp
(syntax-parameterize ([mutator-tail-call? #f])
fe)])
(yes! fe))])
(mutator-begin e ...))]))
; Real Macros
@ -124,13 +128,18 @@
...))
(define-syntax-rule (mutator-if test true false)
(if (syntax-parameterize ([mutator-tail-call? #f])
(collector:deref (->address test)))
(collector:deref (->address (no! test))))
(->address true)
(->address false)))
(define-syntax-rule (mutator-set! id e)
(begin
(set! id (->address e))
(mutator-app void)))
(define-syntax (mutator-set! stx)
(syntax-case stx ()
[(_ id e)
(let ()
(if (syntax-parameter-value #'mutator-assignment-allowed?)
#'(begin
(set! id (->address (no! e)))
(mutator-app void))
(raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))]))
(define-syntax (mutator-let-values stx)
(syntax-case stx ()
[(_ ([(id ...) expr]
@ -151,7 +160,7 @@
#'expr)
(syntax-parameter-value #'mutator-env-roots))]
[mutator-tail-call? #f])
expr)]
(no! expr))]
...)
(let-values ([(id ...) (values tmp ...)]
...)
@ -196,7 +205,7 @@
#'body)
(list #'free-id ...))]
[mutator-tail-call? #t])
(->address body)))])
(->address (no! body))))])
closure))])
#,(if (syntax-parameter-value #'mutator-tail-call?)
(syntax/loc stx
@ -216,6 +225,8 @@
(local [(define (do-not-expand? exp)
(and (identifier? exp)
(or (free-identifier=? exp #'empty)
(free-identifier=? exp #'collector:set-first!)
(free-identifier=? exp #'collector:set-rest!)
(ormap (λ (x) (free-identifier=? x exp))
prim-ids))))
(define exps (syntax->list #'(e ...)))
@ -238,6 +249,12 @@
(let ()
(define prim-app? (ormap (λ (x) (free-identifier=? x #'fe))
prim-ids))
(define is-set-fst? (free-identifier=? #'collector:set-first! #'fe))
(when (or is-set-fst? (free-identifier=? #'collector:set-rest! #'fe))
(unless (syntax-parameter-value #'mutator-assignment-allowed?)
(raise-syntax-error (if is-set-fst? 'set-first! 'set-rest!)
"can appear only at the top-level or in a begin"
stx)))
(with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)]
[app-exp (if prim-app?
(syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...)))
@ -440,14 +457,24 @@
(gc->scheme l))))
(provide (rename-out (mutator-set-first! set-first!)))
(define (mutator-set-first! x y)
(collector:set-first! x y)
(void))
(define-syntax (mutator-set-first! stx)
(syntax-case stx ()
[x
(identifier? #'x)
(raise-syntax-error 'set-first! "must appear immediately following an open paren" stx)]
[(_ args ...)
(begin
#'(mutator-app collector:set-first! args ...))]))
(provide (rename-out (mutator-set-rest! set-rest!)))
(define (mutator-set-rest! x y)
(collector:set-rest! x y)
(void))
(define-syntax (mutator-set-rest! stx)
(syntax-case stx ()
[x
(identifier? #'x)
(raise-syntax-error 'set-rest! "must appear immediately following an open paren" stx)]
[(_ args ...)
(begin
#'(mutator-app collector:set-rest! args ...))]))
(provide (rename-out [mutator-empty empty]))
(define-syntax mutator-empty

60
collects/tests/plai/gc2/set-restriction-test.rkt Normal file
View File

@ -0,0 +1,60 @@
#lang racket
(define-syntax (test stx)
(syntax-case stx ()
[(_ exp reg)
(with-syntax ([line (syntax-line stx)])
#'(test/proc line 'exp reg))]))
(define ns (make-base-namespace))
(define tests 0)
(define failed 0)
(define (test/proc line exp reg)
(set! tests (+ tests 1))
(define err
(with-handlers (((λ (x)
(and (exn:fail:syntax? x)
reg
(let ([m (exn-message x)])
(regexp-match? reg m))))
exn-message))
(parameterize ([current-namespace ns])
(expand
`(,#'module m plai/gc2/mutator
(allocator-setup "good-collectors/trivial-collector.rkt" 200)
(define x '(1))
,exp))
#f)))
(unless (or (and reg err)
(and (not reg) (not err)))
(set! failed (+ failed 1))
(eprintf "test on line ~a failed:\n ~s\n expected ~a, got ~a\n"
line
exp
(if reg (format "a syntax error matching ~a" reg) "no error")
(or err "no error"))))
(test (+ (set! x 2) 1) #rx"set!")
(test (cons (set! x 3) empty) #rx"set!")
(test (set! x 2) #f)
(test (set! x (set! x 2)) #rx"set!")
(test (begin (begin (set! x 2) 1) 2) #f)
(test (λ () (set! x 1)) #rx"set!")
(test (λ () (set! x 1) 2) #f)
(test (let ([y (begin 1 (set! x 2))]) 1) #rx"set!")
(test (let ([y 2]) (begin 1 (set! x 2))) #f)
(test (+ (set-first! x 2) 3) #rx"set-first!")
(test (begin (set-first! x 2) 3) #f)
(test (+ (set-rest! x 2) 3) #rx"set-rest!")
(test (begin (set-rest! x 2) 3) #f)
(test set-first! #rx"set-first!")
(test set-rest! #rx"set-rest!")
(test (if (set! x 1) 2 3) #rx"set!")
(test (if 1 (set! x 2) (set! x 3)) #f)
(cond
[(zero? failed)
(printf "passed ~a tests\n" tests)]
[else
(eprintf "failed ~a test~a\n" failed (if (= 1 failed) "" "s"))])