performance improvements: class local-field access uses accessor with index built in (so the index is checked once); JIT partially inlines struct-field mutation
svn: r14530
This commit is contained in:
Matthew Flatt
parent
0c2c04e168
commit
709ad23400
|
|
@ -384,7 +384,7 @@
|
|||
(not (zero? how-close))
|
||||
((abs how-close) . > . between-threshold))])
|
||||
(let ([snip (and onit?
|
||||
(find-snip pos 'after))])
|
||||
(do-find-snip pos 'after))])
|
||||
(and snip
|
||||
(let-boxes ([x 0.0] [y 0.0])
|
||||
(get-snip-position-and-location snip #f x y)
|
||||
|
|
@ -428,7 +428,7 @@
|
|||
((abs how-close) . > . between-threshold))])
|
||||
(if onit?
|
||||
;; we're in the snip's horizontal region...
|
||||
(let ([snip (find-snip now 'after)])
|
||||
(let ([snip (do-find-snip now 'after)])
|
||||
;; ... but maybe the mouse is above or below it.
|
||||
(let-boxes ([top 0.0]
|
||||
[bottom 0.0]
|
||||
|
|
@ -1332,7 +1332,7 @@
|
|||
(let* ([gsnip (if (not did-one?)
|
||||
(begin
|
||||
(make-snipset start start)
|
||||
(find-snip start 'after-or-none))
|
||||
(do-find-snip start 'after-or-none))
|
||||
before-snip)]
|
||||
[before-snip (or before-snip gsnip)]
|
||||
[inserted-new-line?
|
||||
|
|
@ -1534,7 +1534,7 @@
|
|||
[(or (equal? c #\newline) (equal? c #\tab))
|
||||
(let ([newline? (equal? c #\newline)])
|
||||
(make-snipset (+ i start) (+ i start 1))
|
||||
(let ([snip (find-snip (+ i start) 'after)])
|
||||
(let ([snip (do-find-snip (+ i start) 'after)])
|
||||
(if newline?
|
||||
|
||||
;; forced return - split the snip
|
||||
|
|
@ -1611,7 +1611,7 @@
|
|||
(when (eq? (mline-last-snip (snip->line snip)) snip)
|
||||
(set-mline-last-snip! (snip->line tabsnip) tabsnip))))))
|
||||
|
||||
(let ([snip (find-snip (+ i start 1) 'after)])
|
||||
(let ([snip (do-find-snip (+ i start 1) 'after)])
|
||||
(let ([i (add1 i)])
|
||||
(loop (+ i start)
|
||||
(if (= i addlen) #f (string-snip-buffer snip))
|
||||
|
|
@ -1623,7 +1623,7 @@
|
|||
[(cnt . > . MAX-COUNT-FOR-SNIP)
|
||||
;; divide up snip, because it's too large:
|
||||
(make-snipset (+ i start) (+ i start))
|
||||
(let ([snip (find-snip (+ i start) 'after)])
|
||||
(let ([snip (do-find-snip (+ i start) 'after)])
|
||||
(loop (+ i start)
|
||||
(string-snip-buffer snip)
|
||||
(add1 (string-snip-dtext snip))
|
||||
|
|
@ -1711,8 +1711,8 @@
|
|||
(make-snipset start end)
|
||||
(set! revision-count (add1 revision-count))
|
||||
|
||||
(let* ([start-snip (find-snip start 'before-or-none)]
|
||||
[end-snip (find-snip end 'before)]
|
||||
(let* ([start-snip (do-find-snip start 'before-or-none)]
|
||||
[end-snip (do-find-snip end 'before)]
|
||||
[with-undo? (and with-undo?
|
||||
(zero? s-noundomode))]
|
||||
[rec (if with-undo?
|
||||
|
|
@ -1956,8 +1956,8 @@
|
|||
s-style-list)])
|
||||
(set-common-copy-region-data! (get-region-data startp endp))
|
||||
|
||||
(let ([start (find-snip startp 'after)]
|
||||
[end (find-snip endp 'after-or-none)]
|
||||
(let ([start (do-find-snip startp 'after)]
|
||||
[end (do-find-snip endp 'after-or-none)]
|
||||
[wl? write-locked?]
|
||||
[fl? flow-locked?])
|
||||
|
||||
|
|
@ -2050,7 +2050,7 @@
|
|||
(let ([addpos (snip->count snip)])
|
||||
(insert snip read-insert)
|
||||
(when data
|
||||
(let ([snip (find-snip read-insert 'after)])
|
||||
(let ([snip (do-find-snip read-insert 'after)])
|
||||
(set-snip-data snip data)))
|
||||
(set! read-insert (+ read-insert addpos))))
|
||||
|
||||
|
|
@ -2300,8 +2300,8 @@
|
|||
((clickback-end c) . > . start)
|
||||
;; we're in the right horizontal region, but maybe the mouse
|
||||
;; is above or below the clickback
|
||||
(let ([start (find-snip (clickback-start c) 'after)]
|
||||
[end (find-snip (clickback-end c) 'before)])
|
||||
(let ([start (do-find-snip (clickback-start c) 'after)]
|
||||
[end (do-find-snip (clickback-end c) 'before)])
|
||||
(and start
|
||||
end
|
||||
(let-boxes ([top 0.0]
|
||||
|
|
@ -2510,18 +2510,20 @@
|
|||
(send s-style-list new-named-style "Standard" (send s-style-list basic-style))
|
||||
(send mf ok?))))))]
|
||||
[(or (eq? format 'text) (eq? format 'text-force-cr))
|
||||
(let loop ([saved-cr? #f])
|
||||
(let ([l (read-string 256 f)])
|
||||
(unless (eof-object? l)
|
||||
(let ([l2 (if (equal? l "")
|
||||
l
|
||||
(if (equal? #\return (string-ref l (sub1 (string-length l))))
|
||||
(substring l 0 (sub1 (string-length l)))
|
||||
l))])
|
||||
(insert (regexp-replace* #rx"\r\n"
|
||||
(if saved-cr? (string-append "\r" l2) l2)
|
||||
"\n"))
|
||||
(loop (not (eq? l l2)))))))
|
||||
(let ([s (make-string 1024)])
|
||||
(let loop ([saved-cr? #f])
|
||||
(let ([len (read-string! s f)])
|
||||
(unless (eof-object? len)
|
||||
(let* ([s1 (if (= len (string-length s))
|
||||
s
|
||||
(substring s 0 len))]
|
||||
[s2 (if (equal? #\return (string-ref s1 (sub1 len)))
|
||||
(substring s1 0 (sub1 len))
|
||||
s1)])
|
||||
(insert (regexp-replace* #rx"\r\n"
|
||||
(if saved-cr? (string-append "\r" s2) s2)
|
||||
"\n"))
|
||||
(loop (not (eq? s1 s2))))))))
|
||||
#f])])
|
||||
|
||||
(when fileerr?
|
||||
|
|
@ -2605,8 +2607,8 @@
|
|||
len
|
||||
end)
|
||||
start)])
|
||||
(let ([start-snip (if (zero? len) #f (find-snip start 'after))]
|
||||
[end-snip (if (zero? len) #f (find-snip end 'after-or-none))])
|
||||
(let ([start-snip (if (zero? len) #f (do-find-snip start 'after))]
|
||||
[end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))])
|
||||
(and (do-write-headers-footers f #t)
|
||||
(write-snips-to-file f s-style-list #f start-snip end-snip #f this)
|
||||
(do-write-headers-footers f #f))))))
|
||||
|
|
@ -3524,7 +3526,7 @@
|
|||
(cond
|
||||
[new-style new-style]
|
||||
[caret-style (send s-style-list find-or-create-style caret-style delta)]
|
||||
[else (let ([gsnip (find-snip start 'before)])
|
||||
[else (let ([gsnip (do-find-snip start 'before)])
|
||||
(send s-style-list find-or-create-style (snip->style gsnip) delta))])))]
|
||||
[else
|
||||
(set! write-locked? #t)
|
||||
|
|
@ -3544,7 +3546,7 @@
|
|||
(begin
|
||||
(set! initial-style-needed? #f)
|
||||
(values snips #f))
|
||||
(values (find-snip start 'after) (find-snip end 'after-or-none)))]
|
||||
(values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))]
|
||||
[(rec)
|
||||
(and (zero? s-noundomode)
|
||||
(make-object style-change-record% start end
|
||||
|
|
@ -4007,8 +4009,6 @@
|
|||
(set! write-locked? #t)
|
||||
(set! flow-locked? #t)
|
||||
|
||||
(set-box! a-ptr #f)
|
||||
(set-box! b-ptr #f)
|
||||
(send snip split pos a-ptr b-ptr)
|
||||
|
||||
(set! read-locked? #f)
|
||||
|
|
@ -4071,7 +4071,8 @@
|
|||
(splice-snip snip prev next)
|
||||
(set! snip-count (add1 snip-count))
|
||||
(insert-snip snip ins-snip)
|
||||
(extra snip)
|
||||
(when extra
|
||||
(extra snip))
|
||||
|
||||
(snip-set-admin snip snip-admin)
|
||||
(snip-set-admin ins-snip snip-admin)
|
||||
|
|
@ -4084,11 +4085,11 @@
|
|||
(let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)])
|
||||
(when snip
|
||||
(unless (= s-pos start)
|
||||
(split-one start s-pos snip void)))))
|
||||
(split-one start s-pos snip #f)))))
|
||||
(when (positive? end)
|
||||
(let-values ([(snip s-pos) (find-snip/pos end 'before)])
|
||||
(unless (= (+ s-pos (snip->count snip)) end)
|
||||
(split-one end s-pos snip void)))))
|
||||
(split-one end s-pos snip #f)))))
|
||||
|
||||
(define/private (insert-text-snip start style)
|
||||
(let* ([snip (on-new-string-snip)]
|
||||
|
|
@ -4257,6 +4258,11 @@
|
|||
#f
|
||||
snips))
|
||||
|
||||
(define/private (do-find-snip p direction)
|
||||
;; BEWARE: `len' may not be up-to-date
|
||||
(let-values ([(snip pos) (find-snip/pos p direction)])
|
||||
snip))
|
||||
|
||||
(def/public (find-snip [exact-nonnegative-integer? p]
|
||||
[(symbol-in before-or-none before after after-or-none) direction]
|
||||
[maybe-box? [s-pos #f]])
|
||||
|
|
@ -4270,48 +4276,49 @@
|
|||
(cond
|
||||
[(and (eq? direction 'before-or-none) (zero? p))
|
||||
(values #f 0)]
|
||||
[(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))])
|
||||
(+ (mline-get-position l)
|
||||
(mline-len l)))))
|
||||
(values #f 0)]
|
||||
[else
|
||||
(let* ([line (mline-find-position (unbox line-root-box) p)]
|
||||
[pos (mline-get-position line)]
|
||||
[p (- p pos)])
|
||||
(if (and (eq? direction 'after-or-none)
|
||||
(not (mline-next line))
|
||||
(p . >= . (mline-len line)))
|
||||
;; past the end:
|
||||
(values #f 0)
|
||||
;; within the line:
|
||||
(let-values ([(snip pos p)
|
||||
(let ([snip (mline-snip line)])
|
||||
(if (and (zero? p) (snip->prev snip))
|
||||
;; back up one:
|
||||
(let ([snip (snip->prev snip)])
|
||||
(values snip
|
||||
(- pos (snip->count snip))
|
||||
(+ p (snip->count snip))))
|
||||
(values snip pos p)))])
|
||||
|
||||
(let-values ([(snip pos p)
|
||||
(let ([snip (mline-snip line)])
|
||||
(if (and (zero? p) (snip->prev snip))
|
||||
;; back up one:
|
||||
(let ([snip (snip->prev snip)])
|
||||
(values snip
|
||||
(- pos (snip->count snip))
|
||||
(+ p (snip->count snip))))
|
||||
(values snip pos p)))])
|
||||
|
||||
(let loop ([snip snip]
|
||||
[pos pos]
|
||||
[p p])
|
||||
(if snip
|
||||
(let ([p (- p (snip->count snip))])
|
||||
(cond
|
||||
[(or (and (eq? direction 'on)
|
||||
(zero? p))
|
||||
(and (or (eq? direction 'before)
|
||||
(eq? direction 'before-or-none))
|
||||
(p . <= . 0))
|
||||
(and (or (eq? direction 'after)
|
||||
(eq? direction 'after-or-none))
|
||||
(p . < . 0)))
|
||||
(values snip pos)]
|
||||
[(and (eq? direction 'on)
|
||||
(p . < . 0))
|
||||
(values #f 0)]
|
||||
[else
|
||||
(loop (snip->next snip) (+ pos (snip->count snip)) p)]))
|
||||
(if (not (eq? direction 'after-or-none))
|
||||
(values last-snip (- pos (snip->count last-snip)))
|
||||
(values #f 0))))))]))
|
||||
(let loop ([snip snip]
|
||||
[pos pos]
|
||||
[p p])
|
||||
(if snip
|
||||
(let ([p (- p (snip->count snip))])
|
||||
(cond
|
||||
[(or (and (eq? direction 'on)
|
||||
(zero? p))
|
||||
(and (or (eq? direction 'before)
|
||||
(eq? direction 'before-or-none))
|
||||
(p . <= . 0))
|
||||
(and (or (eq? direction 'after)
|
||||
(eq? direction 'after-or-none))
|
||||
(p . < . 0)))
|
||||
(values snip pos)]
|
||||
[(and (eq? direction 'on)
|
||||
(p . < . 0))
|
||||
(values #f 0)]
|
||||
[else
|
||||
(loop (snip->next snip) (+ pos (snip->count snip)) p)]))
|
||||
(if (not (eq? direction 'after-or-none))
|
||||
(values last-snip (- pos (snip->count last-snip)))
|
||||
(values #f 0)))))))]))
|
||||
|
||||
(def/public (find-next-non-string-snip [(make-or-false snip%) snip])
|
||||
(if (or (and snip
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
"snip.ss"
|
||||
"snip-flags.ss")
|
||||
|
||||
(provide proc-record%
|
||||
(provide change-record%
|
||||
proc-record%
|
||||
unmodify-record%
|
||||
insert-record%
|
||||
insert-snip-record%
|
||||
|
|
|
|||
|
|
@ -1131,6 +1131,8 @@
|
|||
(if (null? l)
|
||||
null
|
||||
(cons pos (loop (add1 pos) (cdr l)))))]
|
||||
[(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))]
|
||||
[(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))]
|
||||
[(plain-init-name ...) (definify plain-init-names)]
|
||||
[(plain-init-name-localized ...) (map lookup-localize plain-init-names)]
|
||||
[(local-plain-init-name ...) (generate-temporaries plain-init-names)])
|
||||
|
|
@ -1164,9 +1166,9 @@
|
|||
(quote the-obj)
|
||||
(quote-syntax local-field)
|
||||
(quote-syntax local-field-localized)
|
||||
(quote-syntax local-accessor)
|
||||
(quote-syntax local-mutator)
|
||||
'(local-field-pos))
|
||||
(quote-syntax local-field-accessor)
|
||||
(quote-syntax local-field-mutator)
|
||||
'())
|
||||
...
|
||||
(make-rename-super-map (quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
|
|
@ -1324,126 +1326,130 @@
|
|||
rename-super-temp ... rename-super-extra-temp ...
|
||||
rename-inner-temp ... rename-inner-extra-temp ...
|
||||
method-accessor ...) ; for a local call that needs a dynamic lookup
|
||||
(syntax-parameterize
|
||||
([this-param (make-this-map (quote-syntax this-id)
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj))])
|
||||
(let-syntaxes
|
||||
mappings
|
||||
(syntax-parameterize
|
||||
([super-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx (rename-super-extra-orig ...)
|
||||
[(_ rename-super-extra-orig . args)
|
||||
(generate-super-call
|
||||
stx
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(quote-syntax rename-super-extra-temp)
|
||||
(syntax args))]
|
||||
...
|
||||
[(_ id . args)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(string-append
|
||||
"identifier for super call does not have an override, "
|
||||
"override-final, overment, or inherit/super declaration")
|
||||
stx
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier after the keyword"
|
||||
stx)]))]
|
||||
[inner-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx (rename-inner-extra-orig ...)
|
||||
[(_ default-expr rename-inner-extra-orig . args)
|
||||
(generate-inner-call
|
||||
stx
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(syntax default-expr)
|
||||
(quote-syntax rename-inner-extra-temp)
|
||||
(syntax args))]
|
||||
...
|
||||
[(_ default-expr id . args)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(string-append
|
||||
"identifier for inner call does not have a pubment, augment, "
|
||||
"overment, or inherit/inner declaration")
|
||||
stx
|
||||
#'id)]
|
||||
[(_)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a default-value expression after the keyword"
|
||||
stx
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier after the keyword and default-value expression"
|
||||
stx)]))])
|
||||
stx-def ...
|
||||
(letrec ([private-temp private-method]
|
||||
...
|
||||
[pubment-temp pubment-method]
|
||||
...
|
||||
[public-final-temp public-final-method]
|
||||
...)
|
||||
(values
|
||||
(list pubment-temp ... public-final-temp ... . public-methods)
|
||||
(list . override-methods)
|
||||
(list . augride-methods)
|
||||
;; Initialization
|
||||
#, ;; Attach srcloc (useful for profiling)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
|
||||
(let-syntax ([the-finder (quote-syntax the-obj)])
|
||||
(syntax-parameterize
|
||||
([super-instantiate-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (arg (... ...)) (kw kwarg) (... ...))
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
|
||||
si_leftovers)
|
||||
(list arg (... ...))
|
||||
(kw kwarg) (... ...))))]))]
|
||||
[super-new-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (kw kwarg) (... ...))
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
|
||||
si_leftovers)
|
||||
null
|
||||
(kw kwarg) (... ...))))]))]
|
||||
[super-make-object-param
|
||||
(lambda (stx)
|
||||
(let ([code
|
||||
(quote-syntax
|
||||
(lambda args
|
||||
(super-go the-obj si_c si_inited? si_leftovers args null)))])
|
||||
(if (identifier? stx)
|
||||
code
|
||||
(datum->syntax
|
||||
code
|
||||
(cons code
|
||||
(cdr (syntax-e stx)))))))])
|
||||
(letrec-syntaxes+values
|
||||
([(plain-init-name) (make-init-redirect
|
||||
(quote-syntax set!)
|
||||
(quote-syntax #%plain-app)
|
||||
(quote-syntax local-plain-init-name)
|
||||
(quote-syntax plain-init-name-localized))] ...)
|
||||
([(local-plain-init-name) undefined] ...)
|
||||
(void) ; in case the body is empty
|
||||
. exprs))))))))))))
|
||||
(let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos)]
|
||||
...
|
||||
[local-field-mutator (make-struct-field-mutator local-mutator local-field-pos)]
|
||||
...)
|
||||
(syntax-parameterize
|
||||
([this-param (make-this-map (quote-syntax this-id)
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj))])
|
||||
(let-syntaxes
|
||||
mappings
|
||||
(syntax-parameterize
|
||||
([super-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx (rename-super-extra-orig ...)
|
||||
[(_ rename-super-extra-orig . args)
|
||||
(generate-super-call
|
||||
stx
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(quote-syntax rename-super-extra-temp)
|
||||
(syntax args))]
|
||||
...
|
||||
[(_ id . args)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(string-append
|
||||
"identifier for super call does not have an override, "
|
||||
"override-final, overment, or inherit/super declaration")
|
||||
stx
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier after the keyword"
|
||||
stx)]))]
|
||||
[inner-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx (rename-inner-extra-orig ...)
|
||||
[(_ default-expr rename-inner-extra-orig . args)
|
||||
(generate-inner-call
|
||||
stx
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(syntax default-expr)
|
||||
(quote-syntax rename-inner-extra-temp)
|
||||
(syntax args))]
|
||||
...
|
||||
[(_ default-expr id . args)
|
||||
(identifier? #'id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(string-append
|
||||
"identifier for inner call does not have a pubment, augment, "
|
||||
"overment, or inherit/inner declaration")
|
||||
stx
|
||||
#'id)]
|
||||
[(_)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a default-value expression after the keyword"
|
||||
stx
|
||||
#'id)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier after the keyword and default-value expression"
|
||||
stx)]))])
|
||||
stx-def ...
|
||||
(letrec ([private-temp private-method]
|
||||
...
|
||||
[pubment-temp pubment-method]
|
||||
...
|
||||
[public-final-temp public-final-method]
|
||||
...)
|
||||
(values
|
||||
(list pubment-temp ... public-final-temp ... . public-methods)
|
||||
(list . override-methods)
|
||||
(list . augride-methods)
|
||||
;; Initialization
|
||||
#, ;; Attach srcloc (useful for profiling)
|
||||
(quasisyntax/loc stx
|
||||
(lambda (the-obj super-go si_c si_inited? si_leftovers init-args)
|
||||
(let-syntax ([the-finder (quote-syntax the-obj)])
|
||||
(syntax-parameterize
|
||||
([super-instantiate-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (arg (... ...)) (kw kwarg) (... ...))
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
|
||||
si_leftovers)
|
||||
(list arg (... ...))
|
||||
(kw kwarg) (... ...))))]))]
|
||||
[super-new-param
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (kw kwarg) (... ...))
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate super-go stx (the-obj si_c si_inited?
|
||||
si_leftovers)
|
||||
null
|
||||
(kw kwarg) (... ...))))]))]
|
||||
[super-make-object-param
|
||||
(lambda (stx)
|
||||
(let ([code
|
||||
(quote-syntax
|
||||
(lambda args
|
||||
(super-go the-obj si_c si_inited? si_leftovers args null)))])
|
||||
(if (identifier? stx)
|
||||
code
|
||||
(datum->syntax
|
||||
code
|
||||
(cons code
|
||||
(cdr (syntax-e stx)))))))])
|
||||
(letrec-syntaxes+values
|
||||
([(plain-init-name) (make-init-redirect
|
||||
(quote-syntax set!)
|
||||
(quote-syntax #%plain-app)
|
||||
(quote-syntax local-plain-init-name)
|
||||
(quote-syntax plain-init-name-localized))] ...)
|
||||
([(local-plain-init-name) undefined] ...)
|
||||
(void) ; in case the body is empty
|
||||
. exprs)))))))))))))
|
||||
;; Not primitive:
|
||||
#f))))))))))))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -142,6 +142,7 @@ static void *stack_cache_pop_code;
|
|||
static void *struct_pred_code, *struct_pred_multi_code;
|
||||
static void *struct_pred_branch_code;
|
||||
static void *struct_get_code, *struct_get_multi_code;
|
||||
static void *struct_set_code, *struct_set_multi_code;
|
||||
static void *bad_app_vals_target;
|
||||
static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
|
||||
static void *finish_tail_call_code, *finish_tail_call_fixup_code;
|
||||
|
|
@ -201,6 +202,9 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter);
|
|||
static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail,
|
||||
int direct_prim, int direct_native, int nontail_self);
|
||||
|
||||
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter,
|
||||
int order_matters, int skipped);
|
||||
|
||||
static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_state *jitter, int stack_start);
|
||||
static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata);
|
||||
|
||||
|
|
@ -1492,31 +1496,36 @@ Scheme_Object *extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, i
|
|||
return NULL;
|
||||
}
|
||||
|
||||
static int check_val_struct_prim(Scheme_Object *p)
|
||||
static int check_val_struct_prim(Scheme_Object *p, int arity)
|
||||
{
|
||||
if (p && SCHEME_PRIMP(p)) {
|
||||
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
|
||||
return 1;
|
||||
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|
||||
return 2;
|
||||
else
|
||||
return 0;
|
||||
} else
|
||||
return 0;
|
||||
if (arity == 1) {
|
||||
if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED)
|
||||
return 1;
|
||||
else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)
|
||||
return 2;
|
||||
} else if (arity == 2) {
|
||||
if ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER)
|
||||
&& ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK)
|
||||
== SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER))
|
||||
return 3;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push)
|
||||
static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push, int arity)
|
||||
{
|
||||
if (jitter->nc) {
|
||||
if (SAME_TYPE(SCHEME_TYPE(o), scheme_toplevel_type)) {
|
||||
Scheme_Object *p;
|
||||
p = extract_global(o, jitter->nc);
|
||||
p = ((Scheme_Bucket *)p)->val;
|
||||
return check_val_struct_prim(p);
|
||||
return check_val_struct_prim(p, arity);
|
||||
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) {
|
||||
Scheme_Object *p;
|
||||
p = extract_closure_local(o, jitter, extra_push);
|
||||
return check_val_struct_prim(p);
|
||||
return check_val_struct_prim(p, arity);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
|
|
@ -1528,23 +1537,24 @@ static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_stat
|
|||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED))
|
||||
return 1;
|
||||
|
||||
if (inlineable_struct_prim(o, jitter, 1))
|
||||
if (inlineable_struct_prim(o, jitter, 1, 1))
|
||||
return 1;
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app)
|
||||
static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter)
|
||||
{
|
||||
return (SCHEME_PRIMP(o)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED));
|
||||
return ((SCHEME_PRIMP(o)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED))
|
||||
|| inlineable_struct_prim(o, jitter, 1, 2));
|
||||
}
|
||||
|
||||
static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app)
|
||||
{
|
||||
return (SCHEME_PRIMP(o)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED)
|
||||
&& (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina)
|
||||
&& (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED)
|
||||
&& (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina)
|
||||
&& (((Scheme_App_Rec *)_app)->num_args <= ((Scheme_Primitive_Proc *)o)->mu.maxa));
|
||||
}
|
||||
|
||||
|
|
@ -1670,7 +1680,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st
|
|||
}
|
||||
break;
|
||||
case scheme_application3_type:
|
||||
if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj))
|
||||
if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter))
|
||||
return 1;
|
||||
else if (just_markless) {
|
||||
return is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2);
|
||||
|
|
@ -2603,7 +2613,9 @@ static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case
|
|||
|
||||
static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands,
|
||||
mz_jit_state *jitter, int is_tail, int multi_ok, int no_call)
|
||||
/* de-sync'd ok */
|
||||
/* de-sync'd ok
|
||||
If no_call is 2, then rator is not necssarily evaluated.
|
||||
If no_call is 1, then rator is left in V1 and arguments are on runstack. */
|
||||
{
|
||||
int i, offset, need_safety = 0;
|
||||
int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0;
|
||||
|
|
@ -2840,7 +2852,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
}
|
||||
|
||||
if (reorder_ok) {
|
||||
if (!no_call) {
|
||||
if (no_call < 2) {
|
||||
generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
|
@ -3893,42 +3905,33 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
|
|||
}
|
||||
|
||||
static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
|
||||
Scheme_Object *rator, Scheme_Object *rand,
|
||||
Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2,
|
||||
jit_insn **for_branch, int branch_short,
|
||||
int multi_ok)
|
||||
/* de-sync'd ok; for branch, sync'd before */
|
||||
{
|
||||
mz_runstack_skipped(jitter, 1);
|
||||
|
||||
LOG_IT(("inlined struct op\n"));
|
||||
|
||||
generate(rator, jitter, 0, 0, JIT_R0); /* sync'd below */
|
||||
CHECK_LIMIT();
|
||||
|
||||
if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) {
|
||||
jit_movr_p(JIT_R1, JIT_R0);
|
||||
generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
if (!rand2) {
|
||||
generate_two_args(rator, rand, jitter, 1, 1); /* sync'd below */
|
||||
CHECK_LIMIT();
|
||||
} else {
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
|
||||
mz_rs_dec(1);
|
||||
CHECK_RUNSTACK_OVERFLOW();
|
||||
mz_runstack_pushed(jitter, 1);
|
||||
mz_rs_str(JIT_R0);
|
||||
Scheme_Object *args[3];
|
||||
args[0] = rator;
|
||||
args[1] = rand;
|
||||
args[2] = rand2;
|
||||
generate_app(NULL, args, 2, jitter, 0, 0, 1); /* sync'd below */
|
||||
CHECK_LIMIT();
|
||||
|
||||
generate_non_tail(rand, jitter, 0, 1); /* sync'd below */
|
||||
CHECK_LIMIT();
|
||||
|
||||
jit_movr_p(JIT_R0, JIT_V1);
|
||||
mz_rs_ldr(JIT_R1);
|
||||
mz_rs_inc(1);
|
||||
mz_runstack_popped(jitter, 1);
|
||||
mz_rs_ldxi(JIT_V1, 1);
|
||||
mz_rs_inc(2); /* sync'd below */
|
||||
mz_runstack_popped(jitter, 2);
|
||||
}
|
||||
|
||||
mz_rs_sync();
|
||||
|
||||
/* R1 is [potential] predicate/getter, R0 is value */
|
||||
/* R0 is [potential] predicate/getter/setting, R1 is struct.
|
||||
V1 is value for setting. */
|
||||
|
||||
if (for_branch) {
|
||||
for_branch[2] = jit_patchable_movi_p(JIT_V1, jit_forward());
|
||||
|
|
@ -3939,12 +3942,18 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter,
|
|||
} else {
|
||||
(void)jit_calli(struct_pred_code);
|
||||
}
|
||||
} else {
|
||||
} else if (kind == 2) {
|
||||
if (multi_ok) {
|
||||
(void)jit_calli(struct_get_multi_code);
|
||||
} else {
|
||||
(void)jit_calli(struct_get_code);
|
||||
}
|
||||
} else {
|
||||
if (multi_ok) {
|
||||
(void)jit_calli(struct_set_multi_code);
|
||||
} else {
|
||||
(void)jit_calli(struct_set_code);
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
|
@ -3962,13 +3971,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|
|||
|
||||
{
|
||||
int k;
|
||||
k = inlineable_struct_prim(rator, jitter, 1);
|
||||
k = inlineable_struct_prim(rator, jitter, 1, 1);
|
||||
if (k == 1) {
|
||||
generate_inlined_struct_op(1, jitter, rator, app->rand, for_branch, branch_short, multi_ok);
|
||||
generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok);
|
||||
scheme_direct_call_count++;
|
||||
return 1;
|
||||
} else if ((k == 2) && !for_branch) {
|
||||
generate_inlined_struct_op(2, jitter, rator, app->rand, for_branch, branch_short, multi_ok);
|
||||
generate_inlined_struct_op(2, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok);
|
||||
scheme_direct_call_count++;
|
||||
return 1;
|
||||
}
|
||||
|
|
@ -4377,7 +4386,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
|
|||
return 0;
|
||||
}
|
||||
|
||||
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters)
|
||||
static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter,
|
||||
int order_matters, int skipped)
|
||||
/* de-sync's rs.
|
||||
Results go into R0 and R1. If !order_matters, and if only the
|
||||
second is simple, then the arguments will be in reverse order. */
|
||||
|
|
@ -4389,7 +4399,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
|
|||
|
||||
if (!simple1) {
|
||||
if (simple2) {
|
||||
mz_runstack_skipped(jitter, 2);
|
||||
mz_runstack_skipped(jitter, skipped);
|
||||
|
||||
generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
|
||||
CHECK_LIMIT();
|
||||
|
|
@ -4406,18 +4416,18 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
|
|||
} else
|
||||
direction = -1;
|
||||
|
||||
mz_runstack_unskipped(jitter, 2);
|
||||
mz_runstack_unskipped(jitter, skipped);
|
||||
} else {
|
||||
mz_runstack_skipped(jitter, 2);
|
||||
mz_runstack_skipped(jitter, skipped);
|
||||
generate_non_tail(rand1, jitter, 0, 1); /* no sync... */
|
||||
CHECK_LIMIT();
|
||||
mz_runstack_unskipped(jitter, 2);
|
||||
mz_runstack_unskipped(jitter, skipped);
|
||||
|
||||
mz_rs_dec(1);
|
||||
CHECK_RUNSTACK_OVERFLOW();
|
||||
mz_runstack_pushed(jitter, 1);
|
||||
mz_rs_str(JIT_R0);
|
||||
mz_runstack_skipped(jitter, 1);
|
||||
mz_runstack_skipped(jitter, skipped-1);
|
||||
|
||||
generate_non_tail(rand2, jitter, 0, 1); /* no sync... */
|
||||
CHECK_LIMIT();
|
||||
|
|
@ -4425,12 +4435,12 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
|
|||
jit_movr_p(JIT_R1, JIT_R0);
|
||||
mz_rs_ldr(JIT_R0);
|
||||
|
||||
mz_runstack_unskipped(jitter, 1);
|
||||
mz_runstack_unskipped(jitter, skipped-1);
|
||||
mz_rs_inc(1);
|
||||
mz_runstack_popped(jitter, 1);
|
||||
}
|
||||
} else {
|
||||
mz_runstack_skipped(jitter, 2);
|
||||
mz_runstack_skipped(jitter, skipped);
|
||||
|
||||
if (simple2) {
|
||||
generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */
|
||||
|
|
@ -4444,7 +4454,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
|
|||
generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */
|
||||
CHECK_LIMIT();
|
||||
|
||||
mz_runstack_unskipped(jitter, 2);
|
||||
mz_runstack_unskipped(jitter, skipped);
|
||||
}
|
||||
|
||||
return direction;
|
||||
|
|
@ -4462,7 +4472,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
|
|||
|
||||
r1 = app->rand1;
|
||||
r2 = app->rand2;
|
||||
direction = generate_two_args(r1, r2, jitter, 1);
|
||||
direction = generate_two_args(r1, r2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
mz_rs_sync();
|
||||
|
|
@ -4604,6 +4614,14 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
{
|
||||
Scheme_Object *rator = app->rator;
|
||||
|
||||
if (!for_branch
|
||||
&& inlineable_struct_prim(rator, jitter, 1, 2)) {
|
||||
generate_inlined_struct_op(3, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, multi_ok);
|
||||
scheme_direct_call_count++;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
if (!SCHEME_PRIMP(rator))
|
||||
return 0;
|
||||
|
||||
|
|
@ -4669,7 +4687,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
__END_SHORT_JUMPS__(branch_short);
|
||||
} else {
|
||||
/* Two complex expressions: */
|
||||
generate_two_args(a2, a1, jitter, 0);
|
||||
generate_two_args(a2, a1, jitter, 0, 2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
mz_rs_sync();
|
||||
|
|
@ -4762,7 +4780,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
&& (SCHEME_INT_VAL(app->rand2) >= 0));
|
||||
|
||||
if (!simple) {
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
mz_rs_sync();
|
||||
|
|
@ -4816,7 +4834,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
|
||||
LOG_IT(("inlined set-mcar!\n"));
|
||||
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
mz_rs_sync();
|
||||
|
||||
|
|
@ -4847,7 +4865,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
|| IS_NAMED_PRIM(rator, "list*")) {
|
||||
LOG_IT(("inlined cons\n"));
|
||||
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
mz_rs_sync();
|
||||
|
||||
|
|
@ -4855,7 +4873,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "mcons")) {
|
||||
LOG_IT(("inlined mcons\n"));
|
||||
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
mz_rs_sync();
|
||||
|
||||
|
|
@ -4881,7 +4899,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|
|||
} else if (IS_NAMED_PRIM(rator, "list")) {
|
||||
LOG_IT(("inlined list\n"));
|
||||
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1);
|
||||
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
mz_rs_dec(1);
|
||||
|
|
@ -5054,7 +5072,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
|
|||
star = IS_NAMED_PRIM(rator, "list*");
|
||||
|
||||
if (c)
|
||||
generate_app(app, NULL, c, jitter, 0, 0, 1);
|
||||
generate_app(app, NULL, c, jitter, 0, 0, 2);
|
||||
CHECK_LIMIT();
|
||||
mz_rs_sync();
|
||||
|
||||
|
|
@ -5145,12 +5163,12 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
|
|||
mz_runstack_unskipped(jitter, 1);
|
||||
c = 1;
|
||||
} else if (app3) {
|
||||
generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */
|
||||
generate_two_args(app3->rand1, app3->rand2, jitter, 1, 2); /* sync'd below */
|
||||
c = 2;
|
||||
} else {
|
||||
c = app->num_args;
|
||||
if (c)
|
||||
generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */
|
||||
generate_app(app, NULL, c, jitter, 0, 0, 2); /* sync'd below */
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
||||
|
|
@ -6652,6 +6670,36 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_
|
|||
return cnt;
|
||||
}
|
||||
|
||||
static int save_struct_temp(mz_jit_state *jitter)
|
||||
{
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(JIT_V(3), JIT_V1);
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef X86_ALIGN_STACK
|
||||
mz_set_local_p(JIT_V1, JIT_LOCAL3);
|
||||
# else
|
||||
jit_pushr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int restore_struct_temp(mz_jit_state *jitter, int reg)
|
||||
{
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(reg, JIT_V(3));
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef X86_ALIGN_STACK
|
||||
mz_get_local_p(reg, JIT_LOCAL3);
|
||||
# else
|
||||
jit_popr_p(reg);
|
||||
# endif
|
||||
#endif
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int do_generate_common(mz_jit_state *jitter, void *_data)
|
||||
{
|
||||
int in, i, ii, iii;
|
||||
|
|
@ -7399,11 +7447,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
__END_TINY_JUMPS__(1);
|
||||
}
|
||||
|
||||
/* *** struct_{pred,get}[_branch]_code *** */
|
||||
/* R1 is (potential) struct proc, R0 is (potential) struct */
|
||||
/* In branch mode, V1 is target address for false branch */
|
||||
/* *** struct_{pred,get,set}[_branch]_code *** */
|
||||
/* R0 is (potential) struct proc, R1 is (potential) struct. */
|
||||
/* In branch mode, V1 is target address for false branch. */
|
||||
/* In set mode, V1 is value to install. */
|
||||
for (ii = 0; ii < 2; ii++) {
|
||||
for (i = 0; i < 3; i++) {
|
||||
for (i = 0; i < 4; i++) {
|
||||
void *code, *code_end;
|
||||
int kind, for_branch;
|
||||
jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6, *bref8;
|
||||
|
|
@ -7424,44 +7473,48 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
for_branch = 1;
|
||||
struct_pred_branch_code = jit_get_ip().ptr;
|
||||
/* Save target address for false branch: */
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(JIT_V(3), JIT_V1);
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef X86_ALIGN_STACK
|
||||
mz_set_local_p(JIT_V1, JIT_LOCAL3);
|
||||
# else
|
||||
jit_pushr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
} else {
|
||||
save_struct_temp(jitter);
|
||||
} else if (i == 2) {
|
||||
kind = 2;
|
||||
for_branch = 0;
|
||||
if (ii == 1)
|
||||
struct_get_multi_code = jit_get_ip().ptr;
|
||||
else
|
||||
struct_get_code = jit_get_ip().ptr;
|
||||
} else {
|
||||
kind = 3;
|
||||
for_branch = 0;
|
||||
if (ii == 1)
|
||||
struct_set_multi_code = jit_get_ip().ptr;
|
||||
else
|
||||
struct_set_code = jit_get_ip().ptr;
|
||||
/* Save value to install: */
|
||||
save_struct_temp(jitter);
|
||||
}
|
||||
|
||||
mz_prolog(JIT_V1);
|
||||
|
||||
__START_SHORT_JUMPS__(1);
|
||||
|
||||
ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1);
|
||||
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Slow path: non-struct proc, or argument type is
|
||||
bad for a getter. */
|
||||
refslow = _jit.x.pc;
|
||||
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1));
|
||||
CHECK_RUNSTACK_OVERFLOW();
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
jit_str_p(JIT_RUNSTACK, JIT_R0);
|
||||
jit_movi_i(JIT_V1, 1);
|
||||
jit_str_p(JIT_RUNSTACK, JIT_R1);
|
||||
if (kind == 3) {
|
||||
restore_struct_temp(jitter, JIT_V1);
|
||||
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_V1);
|
||||
}
|
||||
jit_movi_i(JIT_V1, ((kind == 3) ? 2 : 1));
|
||||
jit_prepare(3);
|
||||
jit_pusharg_p(JIT_RUNSTACK);
|
||||
jit_pusharg_p(JIT_V1);
|
||||
jit_pusharg_p(JIT_R1);
|
||||
jit_pusharg_p(JIT_R0);
|
||||
if (ii == 1) {
|
||||
(void)mz_finish(_scheme_apply_multi_from_native);
|
||||
} else {
|
||||
|
|
@ -7469,7 +7522,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
}
|
||||
jit_retval(JIT_R0);
|
||||
VALIDATE_RESULT(JIT_R0);
|
||||
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
|
||||
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1));
|
||||
JIT_UPDATE_THREAD_RSPTR();
|
||||
if (!for_branch) {
|
||||
mz_epilog(JIT_V1);
|
||||
|
|
@ -7484,24 +7537,29 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
|
||||
/* Continue trying fast path: check proc */
|
||||
mz_patch_branch(ref);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
(void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
|
||||
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
|
||||
? SCHEME_PRIM_IS_STRUCT_PRED
|
||||
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags);
|
||||
if (kind == 3) {
|
||||
jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK);
|
||||
(void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER);
|
||||
} else {
|
||||
(void)jit_bmci_i(refslow, JIT_R2, ((kind == 1)
|
||||
? SCHEME_PRIM_IS_STRUCT_PRED
|
||||
: SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER));
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
/* Check argument: */
|
||||
if (kind == 1) {
|
||||
bref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
|
||||
__START_INNER_TINY__(1);
|
||||
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
|
||||
__END_INNER_TINY__(1);
|
||||
bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
|
||||
} else {
|
||||
(void)jit_bmsi_ul(refslow, JIT_R0, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
|
||||
(void)jit_bmsi_ul(refslow, JIT_R1, 0x1);
|
||||
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
|
||||
__START_INNER_TINY__(1);
|
||||
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
|
||||
__END_INNER_TINY__(1);
|
||||
|
|
@ -7514,15 +7572,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
CHECK_LIMIT();
|
||||
|
||||
/* Put argument struct type in R2, target struct type in V1 */
|
||||
jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind == 2) {
|
||||
jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind >= 2) {
|
||||
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* common case: types are the same */
|
||||
if (kind == 2) {
|
||||
if (kind >= 2) {
|
||||
__START_INNER_TINY__(1);
|
||||
bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1);
|
||||
__END_INNER_TINY__(1);
|
||||
|
|
@ -7542,13 +7600,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
/* Lookup argument type at target type depth, put it in R2: */
|
||||
jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE);
|
||||
jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types);
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype);
|
||||
jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2);
|
||||
CHECK_LIMIT();
|
||||
|
||||
/* Re-load target type into V1: */
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind == 2) {
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
if (kind >= 2) {
|
||||
jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type);
|
||||
}
|
||||
|
||||
|
|
@ -7575,16 +7633,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
mz_patch_branch(bref4);
|
||||
if (for_branch) {
|
||||
mz_patch_branch(bref5);
|
||||
#ifdef MZ_USE_JIT_PPC
|
||||
jit_movr_p(JIT_V1, JIT_V(3));
|
||||
#endif
|
||||
#ifdef MZ_USE_JIT_I386
|
||||
# ifdef X86_ALIGN_STACK
|
||||
mz_get_local_p(JIT_V1, JIT_LOCAL3);
|
||||
# else
|
||||
jit_popr_p(JIT_V1);
|
||||
# endif
|
||||
#endif
|
||||
restore_struct_temp(jitter, JIT_V1);
|
||||
mz_epilog_without_jmp();
|
||||
jit_jmpr(JIT_V1);
|
||||
} else {
|
||||
|
|
@ -7598,11 +7647,17 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
|
|||
mz_patch_branch(bref8);
|
||||
__END_INNER_TINY__(1);
|
||||
/* Extract field */
|
||||
jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val);
|
||||
jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field);
|
||||
jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
|
||||
jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots);
|
||||
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
|
||||
if (kind == 3) {
|
||||
restore_struct_temp(jitter, JIT_R0);
|
||||
jit_stxr_p(JIT_V1, JIT_R1, JIT_R0);
|
||||
(void)jit_movi_p(JIT_R0, scheme_void);
|
||||
} else {
|
||||
jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1);
|
||||
}
|
||||
mz_epilog(JIT_V1);
|
||||
}
|
||||
CHECK_LIMIT();
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user