replace same-closure with procedure-closure-contents-eq?
svn: r2476
This commit is contained in:
Matthew Flatt
parent
ed9d988cd8
commit
d2737c73a4
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
(module contract-ds mzscheme
|
||||
(require "contract-util.ss"
|
||||
"same-closure.ss")
|
||||
(require "contract-util.ss")
|
||||
(require-for-syntax "contract-ds-helpers.ss"
|
||||
"contract-helpers.scm")
|
||||
|
||||
|
|
@ -207,7 +206,7 @@
|
|||
[(and (proj-pred? x) (proj-pred? y))
|
||||
(contract-stronger? x y)]
|
||||
[(and (procedure? x) (procedure? y))
|
||||
(same-closure? x y)]
|
||||
(procedure-closure-contents-eq? x y)]
|
||||
[else #f]))
|
||||
|
||||
#|
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
(module contract-util mzscheme
|
||||
(require "contract-helpers.scm"
|
||||
"same-closure.ss"
|
||||
(lib "pretty.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
|
|
@ -286,14 +285,14 @@
|
|||
(name-prop (λ (ctc) (contract-the-name ctc)))
|
||||
(stronger-prop (λ (this that)
|
||||
(and (contract? that)
|
||||
(same-closure? (contract-the-proc this)
|
||||
(contract-the-proc that)))))))
|
||||
(procedure-closure-contents-eq? (contract-the-proc this)
|
||||
(contract-the-proc that)))))))
|
||||
(define-struct/prop flat-contract (the-name predicate)
|
||||
((proj-prop flat-proj)
|
||||
(stronger-prop (λ (this that)
|
||||
(and (flat-contract? that)
|
||||
(same-closure? (flat-contract-predicate this)
|
||||
(flat-contract-predicate that)))))
|
||||
(procedure-closure-contents-eq? (flat-contract-predicate this)
|
||||
(flat-contract-predicate that)))))
|
||||
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
|
||||
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
|
||||
(values make-flat-contract
|
||||
|
|
|
|||
|
|
@ -1,270 +0,0 @@
|
|||
#|
|
||||
|
||||
does not work for the
|
||||
3m garbage collector
|
||||
(it has a different
|
||||
closure representation)
|
||||
|
||||
assumes the JIT is
|
||||
compiled into mzscheme,
|
||||
but not necc enabled.
|
||||
(If the JIT isn't compiled in,
|
||||
the closure representation
|
||||
changes.)
|
||||
|
||||
|
||||
|#
|
||||
|
||||
(module same-closure mzscheme
|
||||
(require (lib "foreign.ss"))
|
||||
(provide same-closure? closure-size)
|
||||
|
||||
(unsafe!)
|
||||
|
||||
(define 3m? (regexp-match #rx#"3m$" (path->bytes (system-library-subpath))))
|
||||
|
||||
(define-cstruct _scheme-object
|
||||
((so _short)))
|
||||
|
||||
(define-cstruct _scheme-inclhash-object
|
||||
((so _short)
|
||||
(key _short)))
|
||||
|
||||
(define-cstruct _scheme-closure-data
|
||||
((iso _scheme-inclhash-object)
|
||||
(num-params _int)
|
||||
(max-let-depth _int)
|
||||
(closure-size _int)
|
||||
;; more fields here in reality,
|
||||
;; but don't matter for this code.
|
||||
))
|
||||
|
||||
(define-cstruct _scheme-closure
|
||||
((so _short)
|
||||
(code _scheme-closure-data-pointer)
|
||||
;; don't include the array at the end, so
|
||||
;; the indexing computation below is right.
|
||||
))
|
||||
|
||||
(define-cstruct _scheme-native-closure-data
|
||||
((code _pointer)
|
||||
(arity-stuff _pointer)
|
||||
(arity-code _pointer)
|
||||
(max-let-depth _int)
|
||||
(closure-size _int)))
|
||||
|
||||
(define-cstruct _scheme-native-closure
|
||||
((so _short)
|
||||
(code _scheme-native-closure-data-pointer)
|
||||
;; vals go here -- an array of pointers stuck on the end
|
||||
;; of this struct.
|
||||
))
|
||||
|
||||
(define closure-size
|
||||
(if 3m?
|
||||
(λ (a) (error 'closure-size "not supported for 3m"))
|
||||
(λ (a)
|
||||
(cond
|
||||
[(not (procedure? a))
|
||||
(error 'closure-size "expected a procedure, got ~e" a)]
|
||||
[else
|
||||
(let ([ptr-a (malloc _pointer)])
|
||||
(ptr-set! ptr-a _scheme a)
|
||||
(let* ([so-a (ptr-ref ptr-a _scheme-object-pointer)]
|
||||
[a-type (scheme-object-so so-a)])
|
||||
(case a-type
|
||||
[(28)
|
||||
(do-size-work ptr-a so-a
|
||||
_scheme-closure-pointer
|
||||
scheme-closure-code
|
||||
scheme-closure-data-closure-size)]
|
||||
[(29) #f]
|
||||
[(33)
|
||||
(do-size-work ptr-a so-a
|
||||
_scheme-native-closure-pointer
|
||||
scheme-native-closure-code
|
||||
scheme-native-closure-data-closure-size)]
|
||||
[else #f])))]))))
|
||||
|
||||
(define (do-size-work ptr-a so-a _ptr-type code-selector size-selector)
|
||||
(let ([closure-data-a (code-selector (ptr-ref ptr-a _ptr-type))])
|
||||
(size-selector closure-data-a)))
|
||||
|
||||
(define same-closure?
|
||||
(if 3m?
|
||||
(λ (a b) (error 'same-closure? "not supported for 3m"))
|
||||
(λ (a b)
|
||||
(cond
|
||||
[(not (procedure? a))
|
||||
(error 'same-closure? "expected a procedure as first argument, got ~e" a)]
|
||||
[(not (procedure? b))
|
||||
(error 'same-closure? "expected a procedure as first argument, got ~e" b)]
|
||||
[(eq? a b) #t]
|
||||
[else
|
||||
(let ([ptr-a (malloc _pointer)]
|
||||
[ptr-b (malloc _pointer)])
|
||||
(ptr-set! ptr-a _scheme a)
|
||||
(ptr-set! ptr-b _scheme b)
|
||||
(let* ([so-a (ptr-ref ptr-a _scheme-object-pointer)]
|
||||
[a-type (scheme-object-so so-a)]
|
||||
[so-b (ptr-ref ptr-b _scheme-object-pointer)]
|
||||
[b-type (scheme-object-so so-b)])
|
||||
(if (= a-type b-type)
|
||||
(case a-type
|
||||
[(28)
|
||||
(do-work ptr-a ptr-b so-a so-b
|
||||
_scheme-closure-pointer
|
||||
scheme-closure-code
|
||||
scheme-closure-data-closure-size
|
||||
_scheme-closure)]
|
||||
[(29)
|
||||
;; case lambda
|
||||
;; cop out for now
|
||||
(eq? a b)]
|
||||
[(33)
|
||||
(do-work ptr-a ptr-b so-a so-b
|
||||
_scheme-native-closure-pointer
|
||||
scheme-native-closure-code
|
||||
scheme-native-closure-data-closure-size
|
||||
_scheme-native-closure)]
|
||||
[else
|
||||
;(printf "unknown type ~s ~s\n" a a-type)
|
||||
(eq? a b)])
|
||||
#f)))]))))
|
||||
|
||||
(define (do-work ptr-a ptr-b so-a so-b _ptr-type code-selector size-selector _type)
|
||||
(let ([closure-data-a (code-selector (ptr-ref ptr-a _ptr-type))]
|
||||
[closure-data-b (code-selector (ptr-ref ptr-b _ptr-type))])
|
||||
(and (ptr-equal? closure-data-a closure-data-b)
|
||||
(let ([size (size-selector closure-data-a)])
|
||||
(let loop ([i 0])
|
||||
(or (= i size)
|
||||
(let ([index (+ (ctype-sizeof _type)
|
||||
(* (ctype-sizeof _pointer) i))])
|
||||
(and (ptr-equal?
|
||||
(ptr-ref so-a _pointer 'abs index)
|
||||
(ptr-ref so-b _pointer 'abs index))
|
||||
(loop (+ i 1))))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; test cases
|
||||
;; (use eval to construct functions so we can control
|
||||
;; whether or not the JIT is enabled.)
|
||||
;;
|
||||
|
||||
#;
|
||||
(begin
|
||||
(require (lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
"test.scm")
|
||||
|
||||
(define (run-tests)
|
||||
(test (eval `(,closure-size (lambda (x) x)))
|
||||
0)
|
||||
(test (eval `(,closure-size ((lambda (x) (lambda (y) x)) 1)))
|
||||
1)
|
||||
(test (eval `(,closure-size ((lambda (x y) (lambda (z) (x y))) 1 2)))
|
||||
2)
|
||||
(test (eval `(,closure-size (((lambda (x y) (lambda (p q) (lambda (z) (x y p q)))) 1 2) 3 4)))
|
||||
4)
|
||||
|
||||
(test (eval `(,same-closure? (lambda (x) x) (lambda (x) x)))
|
||||
#f)
|
||||
(test (eval `(,same-closure? (call/cc values) (call/cc values)))
|
||||
#f)
|
||||
(test (eval `(,same-closure? + -))
|
||||
#f)
|
||||
(test (eval `(,same-closure? + +))
|
||||
#t)
|
||||
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
|
||||
(,same-closure? (f 1) (f 1))))
|
||||
#t)
|
||||
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
|
||||
(,same-closure? (f f) (f f))))
|
||||
#t)
|
||||
|
||||
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
|
||||
(,same-closure? (f 1) (f 2))))
|
||||
#f)
|
||||
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
|
||||
(,same-closure? (f 1) (f f))))
|
||||
#f)
|
||||
(test (eval `(let ([f 1])
|
||||
(,same-closure?
|
||||
(lambda (x) f)
|
||||
(lambda (x) f))))
|
||||
#f)
|
||||
(test (eval `(let ([f (lambda (x y z p) (lambda (y) (x y z p)))])
|
||||
(,same-closure? (f 1 2 3 4) (f 1 2 3 4))))
|
||||
#t)
|
||||
(test (eval `(let ([f (lambda (x y z p) (lambda (y) (x y z p)))])
|
||||
(,same-closure? (f 1 2 3 5) (f 1 2 3 4))))
|
||||
#f)
|
||||
(test (eval `(let ([f (lambda () (lambda (y) +))])
|
||||
(,same-closure? (f) (f))))
|
||||
#t)
|
||||
(test (eval `(,same-closure? (lambda (y) -) (lambda (y) +)))
|
||||
#f)
|
||||
(test (eval `(begin (module m mzscheme
|
||||
(provide ans)
|
||||
(define (f y z) (lambda (x) (+ x y z)))
|
||||
(define ans (,same-closure? (f 1 2) (f 1 2))))
|
||||
(require m)
|
||||
ans))
|
||||
#t)
|
||||
(test (eval `(begin (module m mzscheme
|
||||
(provide ans)
|
||||
(define (f y z) (lambda (x) (+ x y z)))
|
||||
(define ans (,same-closure? (f 1 2) (f 2 1))))
|
||||
(require m)
|
||||
ans))
|
||||
#f)
|
||||
(test (eval `(let ([f (λ (x)
|
||||
(case-lambda
|
||||
[() x]
|
||||
[(x) x]))])
|
||||
(,same-closure? (f 1) (f f))))
|
||||
#f)
|
||||
|
||||
;; this test fails, because case-lambda isn't handled yet.
|
||||
#;
|
||||
(test (eval `(let ([f (λ (x)
|
||||
(case-lambda
|
||||
[() x]
|
||||
[(x) x]))])
|
||||
(,same-closure? (f 1) (f 1))))
|
||||
#t)
|
||||
|
||||
|
||||
;; make some big closures
|
||||
(let* ([size 4000]
|
||||
[vars (build-list size (λ (x) (string->symbol (format "x~a" x))))]
|
||||
[lam (eval `(λ ,vars
|
||||
(λ (x)
|
||||
(list ,@vars))))]
|
||||
[diff-list (map values vars)])
|
||||
(set-car! (last-pair diff-list) 2) ;; set up difference
|
||||
(test (same-closure? (apply lam vars) (apply lam vars))
|
||||
#t)
|
||||
(test (same-closure? (apply lam vars) (apply lam diff-list))
|
||||
#f)))
|
||||
|
||||
|
||||
(printf "non-jit tests\n")
|
||||
(parameterize ([eval-jit-enabled #f]) (run-tests))
|
||||
(printf "jit tests\n")
|
||||
(parameterize ([eval-jit-enabled #t]) (run-tests))
|
||||
(printf "tests done\n")
|
||||
|
||||
(define (timing-test)
|
||||
(let* ([f (λ (x) (λ (y) x))]
|
||||
[f1 (f 1)]
|
||||
[f2 (f 2)])
|
||||
(let loop ([i 10000])
|
||||
(unless (zero? i)
|
||||
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
|
||||
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
|
||||
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
|
||||
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
|
||||
(loop (- i 1))))))))
|
||||
Loading…
Reference in New Issue
Block a user