cs & schemify: further refinments to left-to-right and letrec
More cases where the code can be mostly left alone, and then cp0 and company can make further improvements.
This commit is contained in:
Matthew Flatt
parent
62e8f27bf7
commit
a8819af26a
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
;; In the Racket source repo, this version should change only when
|
||||
;; "racket_version.h" changes:
|
||||
(define version "7.9.0.20")
|
||||
(define version "7.9.0.21")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -50,10 +50,12 @@
|
|||
(parameterize ([current-compile-target-machine #f])
|
||||
(write (compile e) o))
|
||||
(define lnkl (zo-parse (open-input-bytes (get-output-bytes o))))
|
||||
(unless (linkl-directory? lnkl)
|
||||
(error 'compile/optimize "expected a linklet directory"))
|
||||
(define ht (linkl-directory-table lnkl))
|
||||
(define bundle (hash-ref ht '() #f))
|
||||
(unless (or (linkl-directory? lnkl)
|
||||
(linkl-bundle? lnkl))
|
||||
(error 'compile/optimize "expected a linklet directory or bundle"))
|
||||
(define bundle (if (linkl-directory? lnkl)
|
||||
(hash-ref (linkl-directory-table lnkl) '() #f)
|
||||
lnkl))
|
||||
(unless bundle
|
||||
(error 'compile/optimize (string-append "didn't find main linklet bundle in directory;"
|
||||
" maybe a top-level `begin` sequence?")))
|
||||
|
|
@ -69,7 +71,7 @@
|
|||
(error 'compile/optimize "compiled content does not have expected shape: ~s"
|
||||
s-exp))
|
||||
|
||||
;; Support cross-module inling, at least through one layer of `require`
|
||||
;; Support cross-module inlining, at least through one layer of `require`
|
||||
(define-values (mpi-vector requires provides phase-to-link-modules)
|
||||
(deserialize-requires-and-provides bundle))
|
||||
(define link-modules (hash-ref phase-to-link-modules 0 '()))
|
||||
|
|
@ -82,7 +84,18 @@
|
|||
(define mu (hash-ref mod-uses key #f))
|
||||
(cond
|
||||
[mu
|
||||
(define mp (module-path-index-resolve (module-use-module mu) #f))
|
||||
(define (replace-self mpi)
|
||||
(define-values (name base) (module-path-index-split mpi))
|
||||
(cond
|
||||
[(and (not name) (not base))
|
||||
(make-resolved-module-path 'top-level-module)]
|
||||
[(module-path-index? base)
|
||||
(define new-base (replace-self base))
|
||||
(if (eq? base new-base)
|
||||
mpi
|
||||
(module-path-index-join name new-base))]
|
||||
[else mpi]))
|
||||
(define mp (module-path-index-resolve (replace-self (module-use-module mu)) #f))
|
||||
(define path (resolved-module-path-name mp))
|
||||
(cond
|
||||
[(path? path)
|
||||
|
|
@ -114,28 +127,37 @@
|
|||
[else
|
||||
(new (cdr formals) (new (car formals) env))]))
|
||||
(let loop ([s s] [env #hasheq()])
|
||||
(define (body-loop bodys new-env)
|
||||
;; ad hoc normlization for a pattern that is no different in back end
|
||||
(match bodys
|
||||
[`((let ,bindings . ,body) ,simple)
|
||||
(loop `((let ,bindings ,@body ,simple)) new-env)]
|
||||
[_ (loop bodys new-env)]))
|
||||
(match s
|
||||
[`(lambda ,formals . ,bodys)
|
||||
(define new-env (new formals env))
|
||||
`(lambda ,(loop formals new-env) . ,(loop bodys new-env))]
|
||||
`(lambda ,(loop formals new-env) . ,(body-loop bodys new-env))]
|
||||
[`(case-lambda [,formalss . ,bodyss] ...)
|
||||
`(case-lambda
|
||||
,@(for/list ([formals (in-list formalss)]
|
||||
[bodys (in-list bodyss)])
|
||||
(define new-env (new formals env))
|
||||
`[,(loop formals new-env) . ,(loop bodys new-env)]))]
|
||||
`[,(loop formals new-env) . ,(body-loop bodys new-env)]))]
|
||||
[`(let ([,ids ,rhss] ...) . ,bodys)
|
||||
(define new-env (new ids env))
|
||||
`(let ,(for/list ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
`[,(loop id new-env) ,(loop rhs env)])
|
||||
. ,(loop bodys new-env))]
|
||||
. ,(body-loop bodys new-env))]
|
||||
[`(letrec ([,ids ,rhss] ...) . ,bodys)
|
||||
(define new-env (new ids env))
|
||||
`(letrec ,(for/list ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
`[,(loop id new-env) ,(loop rhs new-env)])
|
||||
. ,(loop bodys new-env))]
|
||||
. ,(body-loop bodys new-env))]
|
||||
[`(quote ,_) s]
|
||||
[`(check-not-unsafe-undefined ,id (quote ,name))
|
||||
`(check-not-unsafe-undefined ,(loop id env) (quote name-dropped-for-normalize))]
|
||||
[`(,es ...)
|
||||
(for/list ([e (in-list es)])
|
||||
(loop e env))]
|
||||
|
|
@ -387,10 +409,10 @@
|
|||
[y (random)])
|
||||
(list x x y y))
|
||||
#f)
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cptypes could improve here
|
||||
`(lambda (x y) (when (and (pair? x) (box? y)) (,e? x y)))
|
||||
`(lambda (x y) (when (and (pair? x) (box? y)) #f)))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cptypes could improve here
|
||||
`(lambda (x y) (car x) (unbox y) (,e? x y))
|
||||
`(lambda (x y) (car x) (unbox y) #f))
|
||||
(test-comp #:except (and (eq? e? 'equal?) 'chez-scheme)
|
||||
|
|
@ -588,7 +610,7 @@
|
|||
(let ([x (list* w z)])
|
||||
(car x)))
|
||||
'(lambda (w z) w))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cadr not specialized
|
||||
'(lambda (w z)
|
||||
(let ([x (list w z)])
|
||||
(cadr x)))
|
||||
|
|
@ -657,13 +679,13 @@
|
|||
(test-comp '(lambda (u v) (cdr (unsafe-cons-list u v)))
|
||||
'(lambda (u v) v))
|
||||
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
|
||||
'(lambda (v) (unbox (box v)))
|
||||
'(lambda (v) v))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
|
||||
'(lambda (v) (unsafe-unbox (box v)))
|
||||
'(lambda (v) v))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; cp0 needs unbox specialization
|
||||
'(lambda (v) (unsafe-unbox* (box v)))
|
||||
'(lambda (v) v))
|
||||
|
||||
|
|
@ -704,7 +726,7 @@
|
|||
'(lambda (w z) (values (with-continuation-mark 'k 'v (read))) (random) #t))
|
||||
(test-comp '(lambda (w z) (vector? (vector w z)))
|
||||
'(lambda (w z) #t))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; vector-immutable is not primitive
|
||||
'(lambda (w z) (vector? (vector-immutable w z)))
|
||||
'(lambda (w z) #t))
|
||||
(test-comp '(lambda (w z) (vector? (list 1)))
|
||||
|
|
@ -746,10 +768,10 @@
|
|||
'(lambda (x) (cdr x) (pair? x)))
|
||||
(test-comp '(lambda (x) (cadr x) #t)
|
||||
'(lambda (x) (cadr x) (pair? x)))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; procedure-arity-includes? is not primitive
|
||||
'(lambda (f) (procedure-arity-includes? f 5) #t)
|
||||
'(lambda (f) (procedure-arity-includes? f 5) (procedure? f)))
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; procedureness is not primitive
|
||||
'(lambda (f l) (f l) #t)
|
||||
'(lambda (f l) (f l) (procedure? f)))
|
||||
|
||||
|
|
@ -774,7 +796,7 @@
|
|||
(test-comp '(lambda (z) (let ([f (lambda (i) (car i))]) (f z)) #t)
|
||||
'(lambda (z) (let ([f (lambda (i) (car i))]) (f z)) (pair? z)))
|
||||
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; real->double-flonum is not primitive
|
||||
'(lambda (z) (fl+ z z))
|
||||
'(lambda (z) (real->double-flonum (fl+ z z))))
|
||||
(test-comp #:except 'chez-scheme
|
||||
|
|
@ -965,7 +987,7 @@
|
|||
#f
|
||||
v v v2 v2))))
|
||||
|
||||
(test-comp #:except 'chez-scheme
|
||||
(test-comp #:except 'chez-scheme ; unsafe car does not assume immutable
|
||||
'(lambda (w z)
|
||||
(if (list w z (random 7))
|
||||
(let ([l (list (random))])
|
||||
|
|
@ -1538,33 +1560,35 @@
|
|||
(if r #t (something-else))))
|
||||
'(lambda (x) (if (something) #t (something-else))))
|
||||
|
||||
(let ([test-if-if-reduction
|
||||
(lambda (dup)
|
||||
(test-comp `(lambda (x y z) (if (if x y #f) z ,dup))
|
||||
`(lambda (x y z) (if x (if y z ,dup) ,dup)))
|
||||
(test-comp `(lambda (x y z) (if (if x #f y) z ,dup))
|
||||
`(lambda (x y z) (if x ,dup (if y z ,dup))))
|
||||
(test-comp `(lambda (x y z) (if (if x y #t) ,dup z))
|
||||
`(lambda (x y z) (if x (if y ,dup z) ,dup)))
|
||||
(test-comp `(lambda (x y z) (if (if x #t y) ,dup z))
|
||||
`(lambda (x y z) (if x ,dup (if y ,dup z)))))])
|
||||
(test-if-if-reduction 1)
|
||||
(test-if-if-reduction ''x)
|
||||
(test-if-if-reduction "x")
|
||||
(test-if-if-reduction #"x")
|
||||
(test-if-if-reduction #t)
|
||||
(test-if-if-reduction #f)
|
||||
(test-if-if-reduction 'car)
|
||||
(test-if-if-reduction 'map))
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(let ([test-if-if-reduction
|
||||
(lambda (dup)
|
||||
(test-comp `(lambda (x y z) (if (if x y #f) z ,dup))
|
||||
`(lambda (x y z) (if x (if y z ,dup) ,dup)))
|
||||
(test-comp `(lambda (x y z) (if (if x #f y) z ,dup))
|
||||
`(lambda (x y z) (if x ,dup (if y z ,dup))))
|
||||
(test-comp `(lambda (x y z) (if (if x y #t) ,dup z))
|
||||
`(lambda (x y z) (if x (if y ,dup z) ,dup)))
|
||||
(test-comp `(lambda (x y z) (if (if x #t y) ,dup z))
|
||||
`(lambda (x y z) (if x ,dup (if y ,dup z)))))])
|
||||
(test-if-if-reduction 1)
|
||||
(test-if-if-reduction ''x)
|
||||
(test-if-if-reduction "x")
|
||||
(test-if-if-reduction #"x")
|
||||
(test-if-if-reduction #t)
|
||||
(test-if-if-reduction #f)
|
||||
(test-if-if-reduction 'car)
|
||||
(test-if-if-reduction 'map)))
|
||||
|
||||
(let ([test-pred-implies-val
|
||||
(lambda (pred? val)
|
||||
(test-comp `(lambda (x) (if (,pred? x) ,val 0))
|
||||
`(lambda (x) (if (,pred? x) x 0)))
|
||||
(test-comp `(lambda (x) (eq? x ,val))
|
||||
`(lambda (x) (,pred? x)))
|
||||
(test-comp `(lambda (x) (eq? ,val x))
|
||||
`(lambda (x) (,pred? x))))])
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-comp `(lambda (x) (eq? x ,val))
|
||||
`(lambda (x) (,pred? x)))
|
||||
(test-comp `(lambda (x) (eq? ,val x))
|
||||
`(lambda (x) (,pred? x)))))])
|
||||
(test-pred-implies-val 'null? 'null)
|
||||
(test-pred-implies-val 'void? '(void))
|
||||
(test-pred-implies-val 'eof-object? 'eof)
|
||||
|
|
@ -1580,13 +1604,15 @@
|
|||
'(lambda (x) (if x 1 (list x))))
|
||||
|
||||
|
||||
(test-comp '(lambda (x) (let ([r (something)])
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x) (let ([r (something)])
|
||||
(r)))
|
||||
'(lambda (x) ((something))))
|
||||
(test-comp '(lambda (x) (let ([r (something)])
|
||||
(r (something-else))))
|
||||
'(lambda (x) ((something) (something-else))))
|
||||
(test-comp '(lambda (x z) (let ([r (something)])
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x z) (let ([r (something)])
|
||||
(z r)))
|
||||
'(lambda (x z) (z (something))))
|
||||
(test-comp '(lambda (x) (let ([r (something)])
|
||||
|
|
@ -1601,7 +1627,8 @@
|
|||
(test-comp '(lambda (x z) (let ([r (something)])
|
||||
(set! z r)))
|
||||
'(lambda (x z) (set! z (something))))
|
||||
(test-comp '(lambda (x z) (let ([r (something)])
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x z) (let ([r (something)])
|
||||
(call-with-values (lambda () (z)) r)))
|
||||
'(lambda (x z) (call-with-values (lambda () (z)) (something))))
|
||||
|
||||
|
|
@ -1685,7 +1712,8 @@
|
|||
'(lambda (x)
|
||||
(let ([n (random 9)]) (random n) (random n) (car x) (cons x 2))))
|
||||
|
||||
(test-comp '(lambda (x)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x)
|
||||
(if (begin (random) (not (begin (random) x))) 1 2))
|
||||
'(lambda (x)
|
||||
(if (begin (random) (random) x) 2 1)))
|
||||
|
|
@ -1722,21 +1750,24 @@
|
|||
(+ y 1))))
|
||||
|
||||
|
||||
(test-comp '(let ()
|
||||
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
|
||||
'(let ()
|
||||
(define (f x)
|
||||
(procedure-specialize
|
||||
(lambda (y) (+ x y))))
|
||||
((f 10) 12))
|
||||
'22)
|
||||
|
||||
(test-comp '(let ()
|
||||
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
|
||||
'(let ()
|
||||
(define (f x)
|
||||
(procedure-specialize
|
||||
(lambda (y) (+ x y))))
|
||||
(procedure? (f 10)))
|
||||
'#t)
|
||||
|
||||
(test-comp '(let ([f (procedure-specialize
|
||||
(test-comp #:except 'chez-scheme ; procedure-specialize doesn't inline enough
|
||||
'(let ([f (procedure-specialize
|
||||
(lambda (y) (+ 1 y)))])
|
||||
(list f (procedure-arity-includes? f 1)))
|
||||
'(let ([f (procedure-specialize
|
||||
|
|
@ -1827,7 +1858,8 @@
|
|||
[y (cons 3 4)])
|
||||
(list x x y)))
|
||||
|
||||
(test-comp '(let ([g (lambda (f)
|
||||
(test-comp #:except 'chez-scheme ; schemify sequences references to `x` in second
|
||||
'(let ([g (lambda (f)
|
||||
(letrec-values ([(x y) (f (cons 1 2)
|
||||
(cons 3 4))])
|
||||
(let ([z x])
|
||||
|
|
@ -1872,7 +1904,8 @@
|
|||
'(lambda (p)
|
||||
(values (unsafe-cdr p) (car p)))
|
||||
#f)
|
||||
(test-comp '(lambda (p)
|
||||
(test-comp #:except 'chez-scheme ; schemify imposes order on car and cdr
|
||||
'(lambda (p)
|
||||
(define-values (x y) (values (car p) (cdr p)))
|
||||
(values y x))
|
||||
'(lambda (p)
|
||||
|
|
@ -1887,7 +1920,8 @@
|
|||
'(lambda (z)
|
||||
(list (list (z 2)) (list z)))
|
||||
#f)
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme ; schemify imposes order: `(z 2)` before `(list z)`
|
||||
'(lambda (z)
|
||||
(let-values ([(a b) (values (list (z 2)) (list z))])
|
||||
(list a a b)))
|
||||
'(lambda (z)
|
||||
|
|
@ -1945,7 +1979,8 @@
|
|||
(set! z 5)))
|
||||
#f)
|
||||
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
;; It's ok to reorder unsafe operations relative
|
||||
;; to each other:
|
||||
(let ([x (unsafe-fx+ z z)]
|
||||
|
|
@ -1963,7 +1998,8 @@
|
|||
(+ (unsafe-car z) (car z)))
|
||||
#f)
|
||||
|
||||
(test-comp '(lambda (z v)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z v)
|
||||
;; It's ok to move an unsafe operation past a
|
||||
;; safe one:
|
||||
(let ([x (unsafe-car v)])
|
||||
|
|
@ -1972,7 +2008,8 @@
|
|||
(+ (car z) (unsafe-car v))))
|
||||
|
||||
;; Ok to reorder arithmetic that will not raise an error:
|
||||
(test-comp '(lambda (x y)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x y)
|
||||
(if (and (real? x) (real? y))
|
||||
(let ([w (+ x y)]
|
||||
[z (- y x)])
|
||||
|
|
@ -1988,7 +2025,8 @@
|
|||
#t])
|
||||
;; Inference of loop variable as number should allow
|
||||
;; additions to be reordered:
|
||||
(test-comp '(lambda ()
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda ()
|
||||
(let loop ([n 0] [m 9])
|
||||
(let ([a (+ n 9)]
|
||||
[b (+ m 10)])
|
||||
|
|
@ -2006,7 +2044,8 @@
|
|||
(+ (values 2 2) (unbox b)))
|
||||
#f)
|
||||
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(let-values ([(x y)
|
||||
(if z
|
||||
(values z (list z))
|
||||
|
|
@ -2015,7 +2054,8 @@
|
|||
'(lambda (z)
|
||||
(list z (if z (list z) (box z)))))
|
||||
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(let-values ([(x y)
|
||||
(if z
|
||||
(values 1 1)
|
||||
|
|
@ -2130,7 +2170,8 @@
|
|||
0)
|
||||
0)
|
||||
|
||||
(test-comp '(letrec ([foo (lambda () 12)]
|
||||
(test-comp #:except 'chez-scheme ; same back-end result, anyway
|
||||
'(letrec ([foo (lambda () 12)]
|
||||
[goo (lambda () foo)])
|
||||
goo)
|
||||
'(let* ([foo (lambda () 12)]
|
||||
|
|
@ -2161,7 +2202,8 @@
|
|||
(parameterize ([compile-context-preservation-enabled
|
||||
;; Avoid different amounts of unrolling
|
||||
#t])
|
||||
(test-comp '(letrec ((even
|
||||
(test-comp #:except 'chez-scheme ;; !! schemify is not good enough here?
|
||||
'(letrec ((even
|
||||
(let ([unused 6])
|
||||
(let ([even (lambda (x) (if (zero? x) #t (even (sub1 x))))])
|
||||
(values even)))))
|
||||
|
|
@ -2208,11 +2250,16 @@
|
|||
(define h (+ a a))
|
||||
(define (y) (x))
|
||||
(list (x) (y) h))
|
||||
'(lambda (a)
|
||||
(define h (+ a a))
|
||||
(letrec ([x (lambda () (y))]
|
||||
[y (lambda () (x))])
|
||||
(list (x) (y) h)))))
|
||||
(if (eq? 'chez-scheme (system-type 'vm))
|
||||
'(lambda (a)
|
||||
(letrec ([x (lambda () (x))])
|
||||
(define h (+ a a))
|
||||
(list (x) (x) h)))
|
||||
'(lambda (a)
|
||||
(define h (+ a a))
|
||||
(letrec ([x (lambda () (y))]
|
||||
[y (lambda () (x))])
|
||||
(list (x) (y) h))))))
|
||||
|
||||
(test-comp '(lambda (f a)
|
||||
(define x (f y))
|
||||
|
|
@ -2249,7 +2296,8 @@
|
|||
[(p) (q)])
|
||||
(list x y z))))
|
||||
|
||||
(test-comp '(lambda (f a)
|
||||
(test-comp #:except 'chez-scheme ;; !! schemify is not good enough here
|
||||
'(lambda (f a)
|
||||
(letrec ([y (if (zero? a)
|
||||
(error "no")
|
||||
8)]
|
||||
|
|
@ -2266,9 +2314,11 @@
|
|||
'(procedure? add1))
|
||||
(test-comp '(lambda () #t)
|
||||
'(lambda () (procedure? add1)))
|
||||
(test-comp #t
|
||||
(test-comp #:except 'chez-scheme
|
||||
#t
|
||||
'(procedure? (lambda (x) x)))
|
||||
(test-comp '(lambda () #t)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda () #t)
|
||||
'(lambda () (procedure? (lambda (x) x))))
|
||||
(test-comp #f
|
||||
'(pair? (lambda (x) x)))
|
||||
|
|
@ -2280,7 +2330,8 @@
|
|||
88))
|
||||
'(let ([f (lambda (x) x)])
|
||||
(list f)))
|
||||
(test-comp '(let ([f (lambda (x) x)])
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(let ([f (lambda (x) x)])
|
||||
(list
|
||||
f
|
||||
f
|
||||
|
|
@ -2303,11 +2354,13 @@
|
|||
|
||||
(test-comp '(lambda (x) #f)
|
||||
'(lambda (x) (pair? (if x car cdr))))
|
||||
(test-comp '(lambda (x) #t)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x) #t)
|
||||
'(lambda (x) (procedure? (if x car cdr))))
|
||||
(test-comp '(lambda (x) #t)
|
||||
'(lambda (x) (fixnum? (if x 2 3))))
|
||||
(test-comp '(lambda (x) #f)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (x) #f)
|
||||
'(lambda (x) (procedure? (if x 2 3))))
|
||||
|
||||
(test-comp '(lambda ()
|
||||
|
|
@ -2377,7 +2430,8 @@
|
|||
'(module m racket/base
|
||||
(printf "pre\n")))
|
||||
|
||||
(test-comp '(module out racket/base
|
||||
(test-comp #:except 'chez-scheme ; test harness `get-module-info` is not smart enough
|
||||
'(module out racket/base
|
||||
(module in racket/base
|
||||
(provide inlinable-function)
|
||||
(define inlinable-function (lambda (x) (list 1 x 3))))
|
||||
|
|
@ -2390,7 +2444,8 @@
|
|||
(require 'in)
|
||||
(lambda () (display (inlinable-function 2)) (inlinable-function 2))))
|
||||
|
||||
(test-comp '(module out racket/base
|
||||
(test-comp #:except 'chez-scheme ; test harness `get-module-info` is not smart enough
|
||||
'(module out racket/base
|
||||
(module in racket/base
|
||||
(provide inlinable-function)
|
||||
(define inlinable-function (lambda (x) (list 1 x 3))))
|
||||
|
|
@ -2406,7 +2461,8 @@
|
|||
(let ([try-equiv
|
||||
(lambda (extras)
|
||||
(lambda (a b)
|
||||
(test-comp `(module m racket/base
|
||||
(test-comp #:except 'chez-scheme ; apply is not primitive
|
||||
`(module m racket/base
|
||||
(define (f x)
|
||||
(apply x ,@extras ,a)))
|
||||
`(module m racket/base
|
||||
|
|
@ -2447,68 +2503,69 @@
|
|||
(define (q x)
|
||||
(+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 (+ x 10))))))))))))))
|
||||
|
||||
(let ([check (lambda (proc arities non-arities)
|
||||
(test-comp `(procedure? ,proc)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm)) ; procedures are not primitivee
|
||||
(let ([check (lambda (proc arities non-arities)
|
||||
(test-comp `(procedure? ,proc)
|
||||
#t)
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure? f)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #t)))
|
||||
(test-comp `(procedure-arity-includes? ,proc -1)
|
||||
#t
|
||||
#f)
|
||||
(test-comp `(procedure-arity-includes? ,proc -1)
|
||||
#f
|
||||
#f)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(procedure-arity-includes? ,proc ,a)
|
||||
#t)
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #t))))
|
||||
arities)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(procedure-arity-includes? ,proc ,a)
|
||||
#f)
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #f))))
|
||||
non-arities))])
|
||||
(check '(lambda (x) x) '(1) '(0 2 3))
|
||||
(check '(lambda (x y) x) '(2) '(0 1 3))
|
||||
(check '(lambda (x . y) x) '(1 2 3) '(0))
|
||||
(check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3))
|
||||
(check '(lambda (x [y #f]) y) '(1 2) '(0 3))
|
||||
(check 'integer? '(1) '(0 2 3))
|
||||
(check 'cons '(2) '(0 1 3))
|
||||
(check 'list '(0 1 2 3) '()))
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure? f)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #t)))
|
||||
(test-comp `(procedure-arity-includes? ,proc -1)
|
||||
#t
|
||||
#f)
|
||||
(test-comp `(procedure-arity-includes? ,proc -1)
|
||||
#f
|
||||
#f)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(procedure-arity-includes? ,proc ,a)
|
||||
#t)
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #t))))
|
||||
arities)
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(test-comp `(procedure-arity-includes? ,proc ,a)
|
||||
#f)
|
||||
(test-comp `(module m racket/base
|
||||
(define f ,proc)
|
||||
(print (procedure-arity-includes? f ,a)))
|
||||
`(module m racket/base
|
||||
(define f ,proc)
|
||||
(print #f))))
|
||||
non-arities))])
|
||||
(check '(lambda (x) x) '(1) '(0 2 3))
|
||||
(check '(lambda (x y) x) '(2) '(0 1 3))
|
||||
(check '(lambda (x . y) x) '(1 2 3) '(0))
|
||||
(check '(case-lambda [() 1] [(x y) x]) '(0 2) '(1 3))
|
||||
(check '(lambda (x [y #f]) y) '(1 2) '(0 3))
|
||||
(check 'integer? '(1) '(0 2 3))
|
||||
(check 'cons '(2) '(0 1 3))
|
||||
(check 'list '(0 1 2 3) '()))
|
||||
|
||||
(test-comp '(lambda () (primitive? car))
|
||||
'(lambda () #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? car 1))
|
||||
'(lambda () #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? car 2))
|
||||
'(lambda () #f))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||
'(lambda () (random) #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||
'(lambda () (random) #f))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||
'(lambda () #t)
|
||||
#f)
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||
'(lambda () #f)
|
||||
#f)
|
||||
(test-comp '(lambda () (primitive? car))
|
||||
'(lambda () #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? car 1))
|
||||
'(lambda () #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? car 2))
|
||||
'(lambda () #f))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||
'(lambda () (random) #t))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||
'(lambda () (random) #f))
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 1))
|
||||
'(lambda () #t)
|
||||
#f)
|
||||
(test-comp '(lambda () (procedure-arity-includes? (begin (random) car) 2))
|
||||
'(lambda () #f)
|
||||
#f))
|
||||
|
||||
(test-comp '(lambda ()
|
||||
(let ([l '(1 2)])
|
||||
|
|
@ -2534,7 +2591,8 @@
|
|||
(test-multi 'list)
|
||||
(test-multi 'list*)
|
||||
(test-multi 'vector)
|
||||
(test-multi 'vector-immutable)))
|
||||
(unless (eq? 'chez-scheme (system-type 'vm)) ; !! vector-immutable is not primitive
|
||||
(test-multi 'vector-immutable))))
|
||||
(test-comp `(let ([x 5])
|
||||
(let ([y (list*)])
|
||||
x))
|
||||
|
|
@ -2575,15 +2633,18 @@
|
|||
(test-pred 'keyword?)
|
||||
(test-pred 'string?)
|
||||
(test-pred 'bytes?)
|
||||
(test-pred 'path?)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-pred 'path?))
|
||||
(test-pred 'char?)
|
||||
(test-pred 'k:interned-char?)
|
||||
(test-pred 'boolean?)
|
||||
(test-pred 'chaperone?)
|
||||
(test-pred 'impersonator?)
|
||||
(test-pred 'procedure?)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-pred 'procedure?))
|
||||
(test-pred 'eof-object?)
|
||||
(test-pred 'immutable?)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-pred 'immutable?))
|
||||
(test-pred 'not)
|
||||
(test-pred 'k:true-object?))
|
||||
|
||||
|
|
@ -2623,15 +2684,17 @@
|
|||
(test-implies 'null? 'k:list-pair? '!=)
|
||||
(test-implies 'null? 'pair? '!=)
|
||||
(test-implies 'null? 'list?)
|
||||
(test-implies 'k:list-pair? 'pair?)
|
||||
(test-implies 'k:list-pair? 'list?)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-implies 'k:list-pair? 'pair?)
|
||||
(test-implies 'k:list-pair? 'list?))
|
||||
(test-implies 'list? 'pair? '?)
|
||||
(test-implies 'k:interned-char? 'char?)
|
||||
(test-implies 'not 'boolean?)
|
||||
(test-implies 'k:true-object? 'boolean?)
|
||||
)
|
||||
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (list? z)
|
||||
(pair? z))
|
||||
(k:list-pair? z)))
|
||||
|
|
@ -2639,7 +2702,8 @@
|
|||
(when (and (list? z)
|
||||
(pair? z))
|
||||
#t)))
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (list? z)
|
||||
(not (null? z)))
|
||||
(k:list-pair? z)))
|
||||
|
|
@ -2647,7 +2711,8 @@
|
|||
(when (and (list? z)
|
||||
(not (null? z)))
|
||||
#t)))
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (list? z)
|
||||
(not (pair? z)))
|
||||
(null? z)))
|
||||
|
|
@ -2655,7 +2720,8 @@
|
|||
(when (and (list? z)
|
||||
(not (pair? z)))
|
||||
#t)))
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (list? z)
|
||||
(not (k:list-pair? z)))
|
||||
(null? z)))
|
||||
|
|
@ -2663,7 +2729,8 @@
|
|||
(when (and (list? z)
|
||||
(not (k:list-pair? z)))
|
||||
#t)))
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (boolean? z)
|
||||
(not (k:true-object? z)))
|
||||
(not z)))
|
||||
|
|
@ -2671,7 +2738,8 @@
|
|||
(when (and (boolean? z)
|
||||
(not (k:true-object? z)))
|
||||
#t)))
|
||||
(test-comp '(lambda (z)
|
||||
(test-comp #:except 'chez-scheme
|
||||
'(lambda (z)
|
||||
(when (and (boolean? z)
|
||||
(not (not z)))
|
||||
(k:true-object? z)))
|
||||
|
|
@ -2731,19 +2799,20 @@
|
|||
(test-reduce 'pair? '(cdr (list 1 2)))
|
||||
(test-reduce 'pair? '(cdr (list 1)) #f)
|
||||
|
||||
(test-reduce 'k:list-pair? 0 #f)
|
||||
(test-reduce 'k:list-pair? ''() #f)
|
||||
(test-reduce 'k:list-pair? ''(1))
|
||||
(test-reduce 'k:list-pair? ''(1 2))
|
||||
#;(test-reduce 'k:list-pair? ''(1 . 2) #f)
|
||||
(test-reduce 'k:list-pair? '(list) #f)
|
||||
(test-reduce 'k:list-pair? '(list 1))
|
||||
(test-reduce 'k:list-pair? '(list 1 2))
|
||||
#;(test-reduce 'k:list-pair? '(cons 1 2) #f)
|
||||
(test-reduce 'k:list-pair? '(cons 1 null))
|
||||
(test-reduce 'k:list-pair? '(cons 1 (list 2 3)))
|
||||
(test-reduce 'k:list-pair? '(cdr (list 1 2)))
|
||||
(test-reduce 'k:list-pair? '(cdr (list 1)) #f)
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(test-reduce 'k:list-pair? 0 #f)
|
||||
(test-reduce 'k:list-pair? ''() #f)
|
||||
(test-reduce 'k:list-pair? ''(1))
|
||||
(test-reduce 'k:list-pair? ''(1 2))
|
||||
#;(test-reduce 'k:list-pair? ''(1 . 2) #f)
|
||||
(test-reduce 'k:list-pair? '(list) #f)
|
||||
(test-reduce 'k:list-pair? '(list 1))
|
||||
(test-reduce 'k:list-pair? '(list 1 2))
|
||||
#;(test-reduce 'k:list-pair? '(cons 1 2) #f)
|
||||
(test-reduce 'k:list-pair? '(cons 1 null))
|
||||
(test-reduce 'k:list-pair? '(cons 1 (list 2 3)))
|
||||
(test-reduce 'k:list-pair? '(cdr (list 1 2)))
|
||||
(test-reduce 'k:list-pair? '(cdr (list 1)) #f))
|
||||
)
|
||||
|
||||
(test-comp '(lambda (z)
|
||||
|
|
@ -5434,7 +5503,9 @@
|
|||
(if (zero? v)
|
||||
(let ([vec (make-vector 6)])
|
||||
(vector-set-performance-stats! vec (current-thread))
|
||||
(vector-ref vec 3))
|
||||
(if (eq? 'chez-scheme (system-type 'vm))
|
||||
0
|
||||
(vector-ref vec 3)))
|
||||
(s? (sub1 v)))))
|
||||
|
||||
(void (f 5)) ; JIT decides that `s?' is a struct predicate
|
||||
|
|
@ -5444,7 +5515,9 @@
|
|||
(define init-size
|
||||
(let ([vec (make-vector 6)])
|
||||
(vector-set-performance-stats! vec (current-thread))
|
||||
(vector-ref vec 3)))
|
||||
(if (eq? 'chez-scheme (system-type 'vm))
|
||||
0
|
||||
(vector-ref vec 3))))
|
||||
(define size (f 500000)) ; make sure that this still leads to a tail loop
|
||||
((- size init-size) . < . 20000)))
|
||||
|
||||
|
|
@ -5454,7 +5527,7 @@
|
|||
;; make sure sfs pass doesn't add a nested begin0
|
||||
;; to clear the variables used in the first expression
|
||||
|
||||
(let ()
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(define c
|
||||
'(module c racket/base
|
||||
(define z (let ([result (random)])
|
||||
|
|
@ -5674,7 +5747,7 @@
|
|||
;; Make sure the compiler unboxes the `v'
|
||||
;; argument in the loop below:
|
||||
|
||||
(let ()
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(define l '(module m racket/base
|
||||
(require racket/flonum)
|
||||
(define (f)
|
||||
|
|
@ -5701,7 +5774,7 @@
|
|||
;; Make sure the compiler doesn't add a check for whether
|
||||
;; `later` is defined in the body of `kw-proc`:
|
||||
|
||||
(let ()
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(define l '(module m racket/base
|
||||
(define (kw-proc x #:optional [optional 0])
|
||||
(later))
|
||||
|
|
@ -5719,7 +5792,7 @@
|
|||
[v (application-rator (lam-body b))])
|
||||
(test #t toplevel-const? v)))
|
||||
|
||||
(let ()
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(define l '(module m racket/base
|
||||
(struct s (x))
|
||||
(define (kw-proc x #:optional [optional 0])
|
||||
|
|
@ -5743,7 +5816,7 @@
|
|||
;; Originally: The validator should understand that a structure
|
||||
;; constructor always succeeds:
|
||||
|
||||
(let ()
|
||||
(unless (eq? 'chez-scheme (system-type 'vm))
|
||||
(define (go sub)
|
||||
(let ([e `(module m racket/base
|
||||
(provide bar)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -2027,19 +2027,19 @@
|
|||
(if (struct-type? struct:known-accessor)
|
||||
struct:known-accessor
|
||||
(check-struct-type 'struct struct:known-accessor))
|
||||
2
|
||||
4
|
||||
0
|
||||
#f
|
||||
'(0 1))
|
||||
'(0 1 2 3))
|
||||
#f
|
||||
#f
|
||||
2
|
||||
3))
|
||||
(define effect_1804
|
||||
4
|
||||
15))
|
||||
(define effect_2706
|
||||
(struct-type-install-properties!
|
||||
struct:known-field-accessor
|
||||
'known-field-accessor
|
||||
2
|
||||
4
|
||||
0
|
||||
(if (struct-type? struct:known-accessor)
|
||||
struct:known-accessor
|
||||
|
|
@ -2047,7 +2047,7 @@
|
|||
null
|
||||
'prefab
|
||||
#f
|
||||
'(0 1)
|
||||
'(0 1 2 3)
|
||||
#f
|
||||
'known-field-accessor))
|
||||
(define known-field-accessor
|
||||
|
|
@ -2087,24 +2087,60 @@
|
|||
s
|
||||
'known-field-accessor
|
||||
'type-id))))))
|
||||
(define known-field-accessor-pos_2286
|
||||
(define known-field-accessor-authentic?_2286
|
||||
(|#%name|
|
||||
known-field-accessor-authentic?
|
||||
(record-accessor struct:known-field-accessor 1)))
|
||||
(define known-field-accessor-authentic?
|
||||
(|#%name|
|
||||
known-field-accessor-authentic?
|
||||
(lambda (s)
|
||||
(if (known-field-accessor?_2878 s)
|
||||
(known-field-accessor-authentic?_2286 s)
|
||||
($value
|
||||
(impersonate-ref
|
||||
known-field-accessor-authentic?_2286
|
||||
struct:known-field-accessor
|
||||
1
|
||||
s
|
||||
'known-field-accessor
|
||||
'authentic?))))))
|
||||
(define known-field-accessor-pos_2482
|
||||
(|#%name|
|
||||
known-field-accessor-pos
|
||||
(record-accessor struct:known-field-accessor 1)))
|
||||
(record-accessor struct:known-field-accessor 2)))
|
||||
(define known-field-accessor-pos
|
||||
(|#%name|
|
||||
known-field-accessor-pos
|
||||
(lambda (s)
|
||||
(if (known-field-accessor?_2878 s)
|
||||
(known-field-accessor-pos_2286 s)
|
||||
(known-field-accessor-pos_2482 s)
|
||||
($value
|
||||
(impersonate-ref
|
||||
known-field-accessor-pos_2286
|
||||
known-field-accessor-pos_2482
|
||||
struct:known-field-accessor
|
||||
1
|
||||
2
|
||||
s
|
||||
'known-field-accessor
|
||||
'pos))))))
|
||||
(define known-field-accessor-known-immutable?_2377
|
||||
(|#%name|
|
||||
known-field-accessor-known-immutable?
|
||||
(record-accessor struct:known-field-accessor 3)))
|
||||
(define known-field-accessor-known-immutable?
|
||||
(|#%name|
|
||||
known-field-accessor-known-immutable?
|
||||
(lambda (s)
|
||||
(if (known-field-accessor?_2878 s)
|
||||
(known-field-accessor-known-immutable?_2377 s)
|
||||
($value
|
||||
(impersonate-ref
|
||||
known-field-accessor-known-immutable?_2377
|
||||
struct:known-field-accessor
|
||||
3
|
||||
s
|
||||
'known-field-accessor
|
||||
'known-immutable?))))))
|
||||
(define struct:known-field-mutator
|
||||
(make-record-type-descriptor*
|
||||
'known-field-mutator
|
||||
|
|
@ -2116,19 +2152,19 @@
|
|||
(if (struct-type? struct:known-mutator)
|
||||
struct:known-mutator
|
||||
(check-struct-type 'struct struct:known-mutator))
|
||||
2
|
||||
3
|
||||
0
|
||||
#f
|
||||
'(0 1))
|
||||
'(0 1 2))
|
||||
#f
|
||||
#f
|
||||
2
|
||||
3))
|
||||
(define effect_2511
|
||||
3
|
||||
7))
|
||||
(define effect_3046
|
||||
(struct-type-install-properties!
|
||||
struct:known-field-mutator
|
||||
'known-field-mutator
|
||||
2
|
||||
3
|
||||
0
|
||||
(if (struct-type? struct:known-mutator)
|
||||
struct:known-mutator
|
||||
|
|
@ -2136,7 +2172,7 @@
|
|||
null
|
||||
'prefab
|
||||
#f
|
||||
'(0 1)
|
||||
'(0 1 2)
|
||||
#f
|
||||
'known-field-mutator))
|
||||
(define known-field-mutator
|
||||
|
|
@ -2176,21 +2212,39 @@
|
|||
s
|
||||
'known-field-mutator
|
||||
'type-id))))))
|
||||
(define known-field-mutator-pos_2735
|
||||
(define known-field-mutator-authentic?_2735
|
||||
(|#%name|
|
||||
known-field-mutator-authentic?
|
||||
(record-accessor struct:known-field-mutator 1)))
|
||||
(define known-field-mutator-authentic?
|
||||
(|#%name|
|
||||
known-field-mutator-authentic?
|
||||
(lambda (s)
|
||||
(if (known-field-mutator?_2222 s)
|
||||
(known-field-mutator-authentic?_2735 s)
|
||||
($value
|
||||
(impersonate-ref
|
||||
known-field-mutator-authentic?_2735
|
||||
struct:known-field-mutator
|
||||
1
|
||||
s
|
||||
'known-field-mutator
|
||||
'authentic?))))))
|
||||
(define known-field-mutator-pos_2749
|
||||
(|#%name|
|
||||
known-field-mutator-pos
|
||||
(record-accessor struct:known-field-mutator 1)))
|
||||
(record-accessor struct:known-field-mutator 2)))
|
||||
(define known-field-mutator-pos
|
||||
(|#%name|
|
||||
known-field-mutator-pos
|
||||
(lambda (s)
|
||||
(if (known-field-mutator?_2222 s)
|
||||
(known-field-mutator-pos_2735 s)
|
||||
(known-field-mutator-pos_2749 s)
|
||||
($value
|
||||
(impersonate-ref
|
||||
known-field-mutator-pos_2735
|
||||
known-field-mutator-pos_2749
|
||||
struct:known-field-mutator
|
||||
1
|
||||
2
|
||||
s
|
||||
'known-field-mutator
|
||||
'pos))))))
|
||||
|
|
|
|||
|
|
@ -2014,7 +2014,8 @@
|
|||
rx1_0
|
||||
(if (if (rx:range? rx1_0) (rx:range? rx2_0) #f)
|
||||
(rx-range
|
||||
(range-union (rx:range-range rx1_0) (rx:range-range rx2_0))
|
||||
(let ((app_0 (rx:range-range rx1_0)))
|
||||
(range-union app_0 (rx:range-range rx2_0)))
|
||||
limit-c_0)
|
||||
(if (if (rx:range? rx1_0)
|
||||
(if (rx:alts? rx2_0) (rx:range? (rx:alts-rx_1874 rx2_0)) #f)
|
||||
|
|
@ -2210,26 +2211,36 @@
|
|||
(define config-case-sensitive
|
||||
(lambda (config_0 cs?_0)
|
||||
(if (parse-config? config_0)
|
||||
(parse-config1.1
|
||||
(parse-config-who config_0)
|
||||
(parse-config-px? config_0)
|
||||
cs?_0
|
||||
(parse-config-multi-line? config_0)
|
||||
(parse-config-group-number-box config_0)
|
||||
(parse-config-references?-box config_0)
|
||||
(parse-config-error-handler? config_0))
|
||||
(let ((app_0 (parse-config-who config_0)))
|
||||
(let ((app_1 (parse-config-px? config_0)))
|
||||
(let ((app_2 (parse-config-multi-line? config_0)))
|
||||
(let ((app_3 (parse-config-group-number-box config_0)))
|
||||
(let ((app_4 (parse-config-references?-box config_0)))
|
||||
(parse-config1.1
|
||||
app_0
|
||||
app_1
|
||||
cs?_0
|
||||
app_2
|
||||
app_3
|
||||
app_4
|
||||
(parse-config-error-handler? config_0)))))))
|
||||
(raise-argument-error 'struct-copy "parse-config?" config_0))))
|
||||
(define config-multi-line
|
||||
(lambda (config_0 mm?_0)
|
||||
(if (parse-config? config_0)
|
||||
(parse-config1.1
|
||||
(parse-config-who config_0)
|
||||
(parse-config-px? config_0)
|
||||
(parse-config-case-sensitive? config_0)
|
||||
mm?_0
|
||||
(parse-config-group-number-box config_0)
|
||||
(parse-config-references?-box config_0)
|
||||
(parse-config-error-handler? config_0))
|
||||
(let ((app_0 (parse-config-who config_0)))
|
||||
(let ((app_1 (parse-config-px? config_0)))
|
||||
(let ((app_2 (parse-config-case-sensitive? config_0)))
|
||||
(let ((app_3 (parse-config-group-number-box config_0)))
|
||||
(let ((app_4 (parse-config-references?-box config_0)))
|
||||
(parse-config1.1
|
||||
app_0
|
||||
app_1
|
||||
app_2
|
||||
mm?_0
|
||||
app_3
|
||||
app_4
|
||||
(parse-config-error-handler? config_0)))))))
|
||||
(raise-argument-error 'struct-copy "parse-config?" config_0))))
|
||||
(define config-group-number
|
||||
(lambda (config_0) (unbox (parse-config-group-number-box config_0))))
|
||||
|
|
@ -4029,11 +4040,13 @@
|
|||
(if (rx:repeat? rx_0)
|
||||
(if (rx:repeat? rx_0)
|
||||
(let ((rx3_0 (convert (rx:repeat-rx rx_0))))
|
||||
(rx:repeat4.1
|
||||
rx3_0
|
||||
(rx:repeat-min rx_0)
|
||||
(rx:repeat-max rx_0)
|
||||
(rx:repeat-non-greedy? rx_0)))
|
||||
(let ((app_0 (rx:repeat-min rx_0)))
|
||||
(let ((app_1 (rx:repeat-max rx_0)))
|
||||
(rx:repeat4.1
|
||||
rx3_0
|
||||
app_0
|
||||
app_1
|
||||
(rx:repeat-non-greedy? rx_0)))))
|
||||
(raise-argument-error 'struct-copy "rx:repeat?" rx_0))
|
||||
(if (rx:maybe? rx_0)
|
||||
(if (rx:maybe? rx_0)
|
||||
|
|
@ -4049,14 +4062,18 @@
|
|||
(convert
|
||||
(rx:conditional-rx_2094 rx_0))))
|
||||
(let ((rx16_1 rx16_0) (tst5_1 tst5_0))
|
||||
(rx:conditional6.1
|
||||
tst5_1
|
||||
rx16_1
|
||||
rx27_0
|
||||
(rx:conditional-n-start rx_0)
|
||||
(rx:conditional-num-n rx_0)
|
||||
(rx:conditional-needs-backtrack?
|
||||
rx_0))))))
|
||||
(let ((app_0
|
||||
(rx:conditional-n-start rx_0)))
|
||||
(let ((app_1
|
||||
(rx:conditional-num-n rx_0)))
|
||||
(rx:conditional6.1
|
||||
tst5_1
|
||||
rx16_1
|
||||
rx27_0
|
||||
app_0
|
||||
app_1
|
||||
(rx:conditional-needs-backtrack?
|
||||
rx_0))))))))
|
||||
(raise-argument-error
|
||||
'struct-copy
|
||||
"rx:conditional?"
|
||||
|
|
@ -4064,11 +4081,13 @@
|
|||
(if (rx:lookahead? rx_0)
|
||||
(if (rx:lookahead? rx_0)
|
||||
(let ((rx8_0 (convert (rx:lookahead-rx rx_0))))
|
||||
(rx:lookahead7.1
|
||||
rx8_0
|
||||
(rx:lookahead-match? rx_0)
|
||||
(rx:lookahead-n-start rx_0)
|
||||
(rx:lookahead-num-n rx_0)))
|
||||
(let ((app_0 (rx:lookahead-match? rx_0)))
|
||||
(let ((app_1 (rx:lookahead-n-start rx_0)))
|
||||
(rx:lookahead7.1
|
||||
rx8_0
|
||||
app_0
|
||||
app_1
|
||||
(rx:lookahead-num-n rx_0)))))
|
||||
(raise-argument-error
|
||||
'struct-copy
|
||||
"rx:lookahead?"
|
||||
|
|
@ -4077,13 +4096,19 @@
|
|||
(if (rx:lookbehind? rx_0)
|
||||
(let ((rx9_0
|
||||
(convert (rx:lookbehind-rx rx_0))))
|
||||
(rx:lookbehind8.1
|
||||
rx9_0
|
||||
(rx:lookbehind-match? rx_0)
|
||||
(rx:lookbehind-lb-min rx_0)
|
||||
(rx:lookbehind-lb-max rx_0)
|
||||
(rx:lookbehind-n-start rx_0)
|
||||
(rx:lookbehind-num-n rx_0)))
|
||||
(let ((app_0 (rx:lookbehind-match? rx_0)))
|
||||
(let ((app_1 (rx:lookbehind-lb-min rx_0)))
|
||||
(let ((app_2
|
||||
(rx:lookbehind-lb-max rx_0)))
|
||||
(let ((app_3
|
||||
(rx:lookbehind-n-start rx_0)))
|
||||
(rx:lookbehind8.1
|
||||
rx9_0
|
||||
app_0
|
||||
app_1
|
||||
app_2
|
||||
app_3
|
||||
(rx:lookbehind-num-n rx_0)))))))
|
||||
(raise-argument-error
|
||||
'struct-copy
|
||||
"rx:lookbehind?"
|
||||
|
|
@ -4091,11 +4116,13 @@
|
|||
(if (rx:cut? rx_0)
|
||||
(if (rx:cut? rx_0)
|
||||
(let ((rx10_0 (convert (rx:cut-rx rx_0))))
|
||||
(rx:cut9.1
|
||||
rx10_0
|
||||
(rx:cut-n-start rx_0)
|
||||
(rx:cut-num-n rx_0)
|
||||
(rx:cut-needs-backtrack? rx_0)))
|
||||
(let ((app_0 (rx:cut-n-start rx_0)))
|
||||
(let ((app_1 (rx:cut-num-n rx_0)))
|
||||
(rx:cut9.1
|
||||
rx10_0
|
||||
app_0
|
||||
app_1
|
||||
(rx:cut-needs-backtrack? rx_0)))))
|
||||
(raise-argument-error
|
||||
'struct-copy
|
||||
"rx:cut?"
|
||||
|
|
@ -4995,13 +5022,14 @@
|
|||
app_1
|
||||
(lazy-bytes-skip-amt s_0)
|
||||
discarded-count_0))))
|
||||
(|#%app|
|
||||
app_0
|
||||
bstr_0
|
||||
app_1
|
||||
(lazy-bytes-progress-evt s_0)
|
||||
(lazy-bytes-in s_0)
|
||||
len_0)))))
|
||||
(let ((app_2 (lazy-bytes-progress-evt s_0)))
|
||||
(|#%app|
|
||||
app_0
|
||||
bstr_0
|
||||
app_1
|
||||
app_2
|
||||
(lazy-bytes-in s_0)
|
||||
len_0))))))
|
||||
(if (eof-object? n_0)
|
||||
#f
|
||||
(if (not (fixnum? n_0))
|
||||
|
|
@ -6904,77 +6932,78 @@
|
|||
(let ((min_0
|
||||
(rx:repeat-min
|
||||
rx_1)))
|
||||
(let ((n_0
|
||||
(rx:repeat-max
|
||||
rx_1)))
|
||||
(let ((max_0
|
||||
(let ((max_0
|
||||
(let ((n_0
|
||||
(rx:repeat-max
|
||||
rx_1)))
|
||||
(if (=
|
||||
n_0
|
||||
+inf.0)
|
||||
#f
|
||||
n_0)))
|
||||
(let ((r-m*_0
|
||||
(compile*/maybe
|
||||
r-rx_0
|
||||
min_0
|
||||
max_0)))
|
||||
(if (if r-m*_0
|
||||
(not
|
||||
(rx:repeat-non-greedy?
|
||||
rx_1))
|
||||
#f)
|
||||
(repeat-simple-many-matcher
|
||||
r-m*_0
|
||||
min_0
|
||||
max_0
|
||||
group-n_0
|
||||
next-m_0)
|
||||
(let ((r-m_0
|
||||
(compile_0
|
||||
r-rx_0
|
||||
(if simple?_0
|
||||
done-m
|
||||
continue-m))))
|
||||
(if (rx:repeat-non-greedy?
|
||||
rx_1)
|
||||
(if simple?_0
|
||||
(lazy-repeat-simple-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0)
|
||||
(lazy-repeat-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0))
|
||||
(if simple?_0
|
||||
(repeat-simple-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
group-n_0
|
||||
next-m_0)
|
||||
(repeat-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0)))))))))))))
|
||||
n_0))))
|
||||
(let ((r-m*_0
|
||||
(compile*/maybe
|
||||
r-rx_0
|
||||
min_0
|
||||
max_0)))
|
||||
(if (if r-m*_0
|
||||
(not
|
||||
(rx:repeat-non-greedy?
|
||||
rx_1))
|
||||
#f)
|
||||
(repeat-simple-many-matcher
|
||||
r-m*_0
|
||||
min_0
|
||||
max_0
|
||||
group-n_0
|
||||
next-m_0)
|
||||
(let ((r-m_0
|
||||
(compile_0
|
||||
r-rx_0
|
||||
(if simple?_0
|
||||
done-m
|
||||
continue-m))))
|
||||
(if (rx:repeat-non-greedy?
|
||||
rx_1)
|
||||
(if simple?_0
|
||||
(lazy-repeat-simple-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0)
|
||||
(lazy-repeat-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0))
|
||||
(if simple?_0
|
||||
(repeat-simple-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
group-n_0
|
||||
next-m_0)
|
||||
(repeat-matcher
|
||||
r-m_0
|
||||
min_0
|
||||
max_0
|
||||
next-m_0))))))))))))
|
||||
(if (rx:group? rx_1)
|
||||
(let ((n_0
|
||||
(rx:group-number
|
||||
rx_1)))
|
||||
(let ((app_0
|
||||
(rx:group-rx rx_1)))
|
||||
(let ((m_0
|
||||
(let ((m_0
|
||||
(let ((app_0
|
||||
(rx:group-rx
|
||||
rx_1)))
|
||||
(compile_0
|
||||
app_0
|
||||
(group-set-matcher
|
||||
n_0
|
||||
next-m_0))))
|
||||
(group-push-matcher
|
||||
n_0
|
||||
m_0))))
|
||||
next-m_0)))))
|
||||
(group-push-matcher
|
||||
n_0
|
||||
m_0)))
|
||||
(if (rx:reference? rx_1)
|
||||
(let ((n_0
|
||||
(rx:reference-n
|
||||
|
|
@ -6994,11 +7023,14 @@
|
|||
(compile_0
|
||||
(rx:cut-rx rx_1)
|
||||
done-m)))
|
||||
(cut-matcher
|
||||
app_0
|
||||
(rx:cut-n-start rx_1)
|
||||
(rx:cut-num-n rx_1)
|
||||
next-m_0))
|
||||
(let ((app_1
|
||||
(rx:cut-n-start
|
||||
rx_1)))
|
||||
(cut-matcher
|
||||
app_0
|
||||
app_1
|
||||
(rx:cut-num-n rx_1)
|
||||
next-m_0)))
|
||||
(if (rx:conditional? rx_1)
|
||||
(let ((tst_0
|
||||
(rx:conditional-tst
|
||||
|
|
@ -7027,14 +7059,16 @@
|
|||
(compile_0
|
||||
tst_0
|
||||
done-m)))
|
||||
(conditional/look-matcher
|
||||
app_0
|
||||
m1_0
|
||||
m2_0
|
||||
(rx:conditional-n-start
|
||||
rx_1)
|
||||
(rx:conditional-num-n
|
||||
rx_1)))))))
|
||||
(let ((app_1
|
||||
(rx:conditional-n-start
|
||||
rx_1)))
|
||||
(conditional/look-matcher
|
||||
app_0
|
||||
m1_0
|
||||
m2_0
|
||||
app_1
|
||||
(rx:conditional-num-n
|
||||
rx_1))))))))
|
||||
(if (rx:lookahead? rx_1)
|
||||
(let ((app_0
|
||||
(rx:lookahead-match?
|
||||
|
|
@ -7044,14 +7078,16 @@
|
|||
(rx:lookahead-rx
|
||||
rx_1)
|
||||
done-m)))
|
||||
(lookahead-matcher
|
||||
app_0
|
||||
app_1
|
||||
(rx:lookahead-n-start
|
||||
rx_1)
|
||||
(rx:lookahead-num-n
|
||||
rx_1)
|
||||
next-m_0)))
|
||||
(let ((app_2
|
||||
(rx:lookahead-n-start
|
||||
rx_1)))
|
||||
(lookahead-matcher
|
||||
app_0
|
||||
app_1
|
||||
app_2
|
||||
(rx:lookahead-num-n
|
||||
rx_1)
|
||||
next-m_0))))
|
||||
(if (rx:lookbehind?
|
||||
rx_1)
|
||||
(let ((app_0
|
||||
|
|
@ -7068,24 +7104,28 @@
|
|||
(rx:lookbehind-rx
|
||||
rx_1)
|
||||
limit-m)))
|
||||
(lookbehind-matcher
|
||||
app_0
|
||||
app_1
|
||||
app_2
|
||||
app_3
|
||||
(rx:lookbehind-n-start
|
||||
rx_1)
|
||||
(rx:lookbehind-num-n
|
||||
rx_1)
|
||||
next-m_0)))))
|
||||
(let ((app_4
|
||||
(rx:lookbehind-n-start
|
||||
rx_1)))
|
||||
(lookbehind-matcher
|
||||
app_0
|
||||
app_1
|
||||
app_2
|
||||
app_3
|
||||
app_4
|
||||
(rx:lookbehind-num-n
|
||||
rx_1)
|
||||
next-m_0))))))
|
||||
(if (rx:unicode-categories?
|
||||
rx_1)
|
||||
(unicode-categories-matcher
|
||||
(rx:unicode-categories-symlist
|
||||
rx_1)
|
||||
(rx:unicode-categories-match?
|
||||
rx_1)
|
||||
next-m_0)
|
||||
(let ((app_0
|
||||
(rx:unicode-categories-symlist
|
||||
rx_1)))
|
||||
(unicode-categories-matcher
|
||||
app_0
|
||||
(rx:unicode-categories-match?
|
||||
rx_1)
|
||||
next-m_0))
|
||||
(error
|
||||
'compile/bt
|
||||
"internal error: unrecognized ~s"
|
||||
|
|
@ -7104,7 +7144,7 @@
|
|||
#f))))))
|
||||
(define struct:rx:regexp
|
||||
(make-record-type-descriptor* 'regexp #f #f #f #f 10 0))
|
||||
(define effect_2629
|
||||
(define effect_2093
|
||||
(struct-type-install-properties!
|
||||
struct:rx:regexp
|
||||
'regexp
|
||||
|
|
@ -7116,8 +7156,9 @@
|
|||
prop:equal+hash
|
||||
(list
|
||||
(lambda (a_0 b_0 eql?_0)
|
||||
(if (eq? (rx:regexp-px? a_0) (rx:regexp-px? b_0))
|
||||
(equal? (rx:regexp-source a_0) (rx:regexp-source b_0))
|
||||
(if (let ((app_0 (rx:regexp-px? a_0))) (eq? app_0 (rx:regexp-px? b_0)))
|
||||
(let ((app_0 (rx:regexp-source a_0)))
|
||||
(equal? app_0 (rx:regexp-source b_0)))
|
||||
#f))
|
||||
(lambda (a_0 hc_0) (|#%app| hc_0 (rx:regexp-source a_0)))
|
||||
(lambda (a_0 hc_0) (|#%app| hc_0 (rx:regexp-source a_0)))))
|
||||
|
|
@ -8099,26 +8140,27 @@
|
|||
(args (raise-binding-result-arity-error 2 args))))))))
|
||||
(define fast-drive-regexp-match-positions/bytes
|
||||
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match
|
||||
rx_0
|
||||
in_0
|
||||
start-pos_0
|
||||
start-pos_0
|
||||
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
|
||||
state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(if ms-pos_0
|
||||
(if state_0
|
||||
(let ((app_0 (cons ms-pos_0 me-pos_0)))
|
||||
(cons app_0 (vector->list state_0)))
|
||||
(list (cons ms-pos_0 me-pos_0)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args))))))))
|
||||
(let ((state_0
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(if (positive? n_0) (make-vector n_0 #f) #f))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match
|
||||
rx_0
|
||||
in_0
|
||||
start-pos_0
|
||||
start-pos_0
|
||||
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
|
||||
state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(if ms-pos_0
|
||||
(if state_0
|
||||
(let ((app_0 (cons ms-pos_0 me-pos_0)))
|
||||
(cons app_0 (vector->list state_0)))
|
||||
(list (cons ms-pos_0 me-pos_0)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args)))))))
|
||||
(define fast-drive-regexp-match-positions/string
|
||||
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
|
||||
(let ((in_0
|
||||
|
|
@ -8127,147 +8169,26 @@
|
|||
0
|
||||
start-offset_0
|
||||
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(let ((string-offset_0
|
||||
(|#%name|
|
||||
string-offset
|
||||
(lambda (pos_0)
|
||||
(begin
|
||||
(+
|
||||
start-offset_0
|
||||
(bytes-utf-8-length in_0 '#\x3f 0 pos_0)))))))
|
||||
(if ms-pos_0
|
||||
(let ((app_0
|
||||
(let ((app_0 (string-offset_0 ms-pos_0)))
|
||||
(cons app_0 (string-offset_0 me-pos_0)))))
|
||||
(cons
|
||||
app_0
|
||||
(if state_0
|
||||
(reverse$1
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(begin
|
||||
(check-vector state_0)
|
||||
(values state_0 (unsafe-vector-length state_0))))
|
||||
(case-lambda
|
||||
((vec_0 len_0)
|
||||
(begin
|
||||
#f
|
||||
(letrec*
|
||||
((for-loop_0
|
||||
(|#%name|
|
||||
for-loop
|
||||
(lambda (fold-var_0 pos_0)
|
||||
(begin
|
||||
(if (unsafe-fx< pos_0 len_0)
|
||||
(let ((p_0
|
||||
(unsafe-vector-ref vec_0 pos_0)))
|
||||
(let ((fold-var_1
|
||||
(let ((fold-var_1
|
||||
(cons
|
||||
(if p_0
|
||||
(let ((app_1
|
||||
(string-offset_0
|
||||
(car p_0))))
|
||||
(cons
|
||||
app_1
|
||||
(string-offset_0
|
||||
(cdr p_0))))
|
||||
#f)
|
||||
fold-var_0)))
|
||||
(values fold-var_1))))
|
||||
(for-loop_0
|
||||
fold-var_1
|
||||
(unsafe-fx+ 1 pos_0))))
|
||||
fold-var_0))))))
|
||||
(for-loop_0 null 0))))
|
||||
(args (raise-binding-result-arity-error 2 args)))))
|
||||
null)))
|
||||
#f)))
|
||||
(args (raise-binding-result-arity-error 2 args)))))))))
|
||||
(define fast-drive-regexp-match/bytes
|
||||
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
|
||||
(let ((state_0
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(if (positive? n_0) (make-vector n_0 #f) #f))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match
|
||||
rx_0
|
||||
in_0
|
||||
start-pos_0
|
||||
start-pos_0
|
||||
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
|
||||
state_0))
|
||||
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(if ms-pos_0
|
||||
(let ((app_0 (subbytes in_0 ms-pos_0 me-pos_0)))
|
||||
(cons
|
||||
app_0
|
||||
(if state_0
|
||||
(reverse$1
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(begin
|
||||
(check-vector state_0)
|
||||
(values state_0 (unsafe-vector-length state_0))))
|
||||
(case-lambda
|
||||
((vec_0 len_0)
|
||||
(begin
|
||||
#f
|
||||
(letrec*
|
||||
((for-loop_0
|
||||
(|#%name|
|
||||
for-loop
|
||||
(lambda (fold-var_0 pos_0)
|
||||
(begin
|
||||
(if (unsafe-fx< pos_0 len_0)
|
||||
(let ((p_0 (unsafe-vector-ref vec_0 pos_0)))
|
||||
(let ((fold-var_1
|
||||
(let ((fold-var_1
|
||||
(cons
|
||||
(if p_0
|
||||
(let ((app_1 (car p_0)))
|
||||
(subbytes
|
||||
in_0
|
||||
app_1
|
||||
(cdr p_0)))
|
||||
#f)
|
||||
fold-var_0)))
|
||||
(values fold-var_1))))
|
||||
(for-loop_0
|
||||
fold-var_1
|
||||
(unsafe-fx+ 1 pos_0))))
|
||||
fold-var_0))))))
|
||||
(for-loop_0 null 0))))
|
||||
(args (raise-binding-result-arity-error 2 args)))))
|
||||
null)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args))))))))
|
||||
(define fast-drive-regexp-match/string
|
||||
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
|
||||
(let ((in_0
|
||||
(string->bytes/utf-8
|
||||
in-str_0
|
||||
0
|
||||
start-offset_0
|
||||
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(let ((state_0 (if (positive? n_0) (make-vector n_0 #f) #f)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(let ((string-offset_0
|
||||
(|#%name|
|
||||
string-offset
|
||||
(lambda (pos_0)
|
||||
(begin
|
||||
(+
|
||||
start-offset_0
|
||||
(bytes-utf-8-length in_0 '#\x3f 0 pos_0)))))))
|
||||
(if ms-pos_0
|
||||
(let ((app_0
|
||||
(bytes->string/utf-8 in_0 '#\x3f ms-pos_0 me-pos_0)))
|
||||
(let ((app_0 (string-offset_0 ms-pos_0)))
|
||||
(cons app_0 (string-offset_0 me-pos_0)))))
|
||||
(cons
|
||||
app_0
|
||||
(if state_0
|
||||
|
|
@ -8294,12 +8215,13 @@
|
|||
(let ((fold-var_1
|
||||
(cons
|
||||
(if p_0
|
||||
(let ((app_1 (car p_0)))
|
||||
(bytes->string/utf-8
|
||||
in_0
|
||||
'#\x3f
|
||||
(let ((app_1
|
||||
(string-offset_0
|
||||
(car p_0))))
|
||||
(cons
|
||||
app_1
|
||||
(cdr p_0)))
|
||||
(string-offset_0
|
||||
(cdr p_0))))
|
||||
#f)
|
||||
fold-var_0)))
|
||||
(values fold-var_1))))
|
||||
|
|
@ -8310,8 +8232,129 @@
|
|||
(for-loop_0 null 0))))
|
||||
(args (raise-binding-result-arity-error 2 args)))))
|
||||
null)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args)))))))))
|
||||
#f)))
|
||||
(args (raise-binding-result-arity-error 2 args))))))))
|
||||
(define fast-drive-regexp-match/bytes
|
||||
(lambda (rx_0 in_0 start-pos_0 end-pos_0)
|
||||
(let ((state_0
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(if (positive? n_0) (make-vector n_0 #f) #f))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match
|
||||
rx_0
|
||||
in_0
|
||||
start-pos_0
|
||||
start-pos_0
|
||||
(if end-pos_0 end-pos_0 (unsafe-bytes-length in_0))
|
||||
state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(if ms-pos_0
|
||||
(let ((app_0 (subbytes in_0 ms-pos_0 me-pos_0)))
|
||||
(cons
|
||||
app_0
|
||||
(if state_0
|
||||
(reverse$1
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(begin
|
||||
(check-vector state_0)
|
||||
(values state_0 (unsafe-vector-length state_0))))
|
||||
(case-lambda
|
||||
((vec_0 len_0)
|
||||
(begin
|
||||
#f
|
||||
(letrec*
|
||||
((for-loop_0
|
||||
(|#%name|
|
||||
for-loop
|
||||
(lambda (fold-var_0 pos_0)
|
||||
(begin
|
||||
(if (unsafe-fx< pos_0 len_0)
|
||||
(let ((p_0 (unsafe-vector-ref vec_0 pos_0)))
|
||||
(let ((fold-var_1
|
||||
(let ((fold-var_1
|
||||
(cons
|
||||
(if p_0
|
||||
(let ((app_1 (car p_0)))
|
||||
(subbytes
|
||||
in_0
|
||||
app_1
|
||||
(cdr p_0)))
|
||||
#f)
|
||||
fold-var_0)))
|
||||
(values fold-var_1))))
|
||||
(for-loop_0
|
||||
fold-var_1
|
||||
(unsafe-fx+ 1 pos_0))))
|
||||
fold-var_0))))))
|
||||
(for-loop_0 null 0))))
|
||||
(args (raise-binding-result-arity-error 2 args)))))
|
||||
null)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args)))))))
|
||||
(define fast-drive-regexp-match/string
|
||||
(lambda (rx_0 in-str_0 start-offset_0 end-offset_0)
|
||||
(let ((in_0
|
||||
(string->bytes/utf-8
|
||||
in-str_0
|
||||
0
|
||||
start-offset_0
|
||||
(if end-offset_0 end-offset_0 (string-length in-str_0)))))
|
||||
(let ((state_0
|
||||
(let ((n_0 (rx:regexp-num-groups rx_0)))
|
||||
(if (positive? n_0) (make-vector n_0 #f) #f))))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(search-match rx_0 in_0 0 0 (unsafe-bytes-length in_0) state_0))
|
||||
(case-lambda
|
||||
((ms-pos_0 me-pos_0)
|
||||
(if ms-pos_0
|
||||
(let ((app_0 (bytes->string/utf-8 in_0 '#\x3f ms-pos_0 me-pos_0)))
|
||||
(cons
|
||||
app_0
|
||||
(if state_0
|
||||
(reverse$1
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(begin
|
||||
(check-vector state_0)
|
||||
(values state_0 (unsafe-vector-length state_0))))
|
||||
(case-lambda
|
||||
((vec_0 len_0)
|
||||
(begin
|
||||
#f
|
||||
(letrec*
|
||||
((for-loop_0
|
||||
(|#%name|
|
||||
for-loop
|
||||
(lambda (fold-var_0 pos_0)
|
||||
(begin
|
||||
(if (unsafe-fx< pos_0 len_0)
|
||||
(let ((p_0 (unsafe-vector-ref vec_0 pos_0)))
|
||||
(let ((fold-var_1
|
||||
(let ((fold-var_1
|
||||
(cons
|
||||
(if p_0
|
||||
(let ((app_1 (car p_0)))
|
||||
(bytes->string/utf-8
|
||||
in_0
|
||||
'#\x3f
|
||||
app_1
|
||||
(cdr p_0)))
|
||||
#f)
|
||||
fold-var_0)))
|
||||
(values fold-var_1))))
|
||||
(for-loop_0
|
||||
fold-var_1
|
||||
(unsafe-fx+ 1 pos_0))))
|
||||
fold-var_0))))))
|
||||
(for-loop_0 null 0))))
|
||||
(args (raise-binding-result-arity-error 2 args)))))
|
||||
null)))
|
||||
#f))
|
||||
(args (raise-binding-result-arity-error 2 args))))))))
|
||||
(define drive-regexp-match.1
|
||||
(|#%name|
|
||||
drive-regexp-match
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -45,9 +45,10 @@
|
|||
(if (struct-type-info-pure-constructor? info)
|
||||
(known-struct-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type struct:s)
|
||||
a-known-constant))]
|
||||
[authentic? (struct-type-info-authentic? info)]
|
||||
[knowns (hash-set knowns
|
||||
(unwrap s?)
|
||||
(known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))]
|
||||
(known-struct-predicate 2 type struct:s authentic?))]
|
||||
[knowns
|
||||
(let* ([immediate-count (struct-type-info-immediate-field-count info)]
|
||||
[parent-count (- (struct-type-info-field-count info)
|
||||
|
|
@ -62,10 +63,14 @@
|
|||
(cond
|
||||
[(and (wrap-eq? make 'make-struct-field-accessor)
|
||||
(wrap-eq? ref-or-set -ref))
|
||||
(hash-set knowns (unwrap id) (known-field-accessor 2 type struct:s (+ parent-count pos)))]
|
||||
(define immutable? (memv pos (or (struct-type-info-prefab-immutables info)
|
||||
(struct-type-info-non-prefab-immutables info)
|
||||
'())))
|
||||
(hash-set knowns (unwrap id) (known-field-accessor 2 type struct:s authentic? (+ parent-count pos)
|
||||
immutable?))]
|
||||
[(and (wrap-eq? make 'make-struct-field-mutator)
|
||||
(wrap-eq? ref-or-set -set!))
|
||||
(hash-set knowns (unwrap id) (known-field-mutator 4 type struct:s (+ parent-count pos)))]
|
||||
(hash-set knowns (unwrap id) (known-field-mutator 4 type struct:s authentic? (+ parent-count pos)))]
|
||||
[else knowns]))
|
||||
knowns)]
|
||||
[`,_ knowns])))])
|
||||
|
|
|
|||
|
|
@ -277,7 +277,9 @@
|
|||
(known-field-accessor/need-imports (known-procedure-arity-mask k)
|
||||
(known-accessor-type k)
|
||||
(known-field-accessor-type-id k)
|
||||
(known-field-accessor-authentic? k)
|
||||
(known-field-accessor-pos k)
|
||||
(known-field-accessor-known-immutable? k)
|
||||
(needed->list needed))]
|
||||
[else
|
||||
(known-accessor (known-procedure-arity-mask k)
|
||||
|
|
@ -289,6 +291,7 @@
|
|||
(known-field-mutator/need-imports (known-procedure-arity-mask k)
|
||||
(known-mutator-type k)
|
||||
(known-field-mutator-type-id k)
|
||||
(known-field-mutator-authentic? k)
|
||||
(known-field-mutator-pos k)
|
||||
(needed->list needed))]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -36,8 +36,10 @@
|
|||
known-mutator known-mutator? known-mutator-type
|
||||
known-struct-constructor known-struct-constructor? known-struct-constructor-type-id
|
||||
known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic?
|
||||
known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-pos
|
||||
known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-pos
|
||||
known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-authentic?
|
||||
known-field-accessor-pos known-field-accessor-known-immutable?
|
||||
known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-authentic?
|
||||
known-field-mutator-pos
|
||||
known-struct-constructor/need-imports known-struct-constructor/need-imports? known-struct-constructor/need-imports-needed
|
||||
known-struct-predicate/need-imports known-struct-predicate/need-imports? known-struct-predicate/need-imports-needed
|
||||
known-field-accessor/need-imports known-field-accessor/need-imports? known-field-accessor/need-imports-needed
|
||||
|
|
@ -122,8 +124,8 @@
|
|||
(struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
|
||||
(struct known-struct-constructor (type-id) #:prefab #:omit-define-syntaxes #:super struct:known-constructor)
|
||||
(struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
|
||||
(struct known-field-accessor (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
|
||||
(struct known-field-mutator (type-id pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
|
||||
(struct known-field-accessor (type-id authentic? pos known-immutable?) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
|
||||
(struct known-field-mutator (type-id authentic? pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
|
||||
(struct known-struct-constructor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-constructor)
|
||||
(struct known-struct-predicate/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-predicate)
|
||||
(struct known-field-accessor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-field-accessor)
|
||||
|
|
|
|||
|
|
@ -857,7 +857,8 @@
|
|||
(cond
|
||||
[type-id
|
||||
(define tmp (maybe-tmp (car args) 'v))
|
||||
(define sel (if unsafe-mode?
|
||||
(define sel (if (and unsafe-mode?
|
||||
(known-field-accessor-authentic? k))
|
||||
`(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
|
||||
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
||||
(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
|
||||
|
|
@ -874,7 +875,8 @@
|
|||
[type-id
|
||||
(define tmp (maybe-tmp (car args) 'v))
|
||||
(define tmp-rhs (maybe-tmp (cadr args) 'rhs))
|
||||
(define mut (if unsafe-mode?
|
||||
(define mut (if (and unsafe-mode?
|
||||
(known-field-mutator-authentic? k))
|
||||
`(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
|
||||
`(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
|
||||
(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
|
||||
|
|
|
|||
|
|
@ -107,15 +107,25 @@
|
|||
(let ([v (or (hash-ref-either knowns imports proc)
|
||||
(hash-ref prim-knowns proc #f))])
|
||||
(and (if pure?
|
||||
(and (if no-alloc?
|
||||
(known-procedure/pure? v)
|
||||
(or (known-procedure/allocates? v)
|
||||
(and unsafe-mode?
|
||||
(known-accessor? v))))
|
||||
(and (or (if no-alloc?
|
||||
(known-procedure/pure? v)
|
||||
(known-procedure/allocates? v))
|
||||
;; in unsafe mode, we can assume no constract error:
|
||||
(and unsafe-mode?
|
||||
(known-field-accessor? v)
|
||||
(known-field-accessor-authentic? v)
|
||||
(known-field-accessor-known-immutable? v)))
|
||||
(returns 1))
|
||||
(and (or (known-procedure/no-prompt? v)
|
||||
(known-procedure/no-prompt/multi? v))
|
||||
(eqv? result-arity #f)))
|
||||
(or (and (known-procedure/no-prompt? v)
|
||||
(returns 1))
|
||||
(and (known-procedure/no-prompt/multi? v)
|
||||
(eqv? result-arity #f))
|
||||
(and (known-field-accessor? v)
|
||||
(known-field-accessor-authentic? v)
|
||||
(returns 1))
|
||||
(and (known-field-mutator? v)
|
||||
(known-field-mutator-authentic? v)
|
||||
(returns 1))))
|
||||
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
|
||||
(simple-mutated-state? (hash-ref mutated proc #f))
|
||||
(for/and ([arg (in-list args)])
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@
|
|||
(proc)))
|
||||
(void))
|
||||
|
||||
(struct os-semaphore ([count #:mutable] mutex condition))
|
||||
(struct os-semaphore ([count #:mutable] mutex condition)
|
||||
#:authentic)
|
||||
|
||||
(define/who (unsafe-make-os-semaphore)
|
||||
(unless threaded? (raise-unsupported who))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 9
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 20
|
||||
#define MZSCHEME_VERSION_W 21
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user