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

performance improvements: class local-field access uses accessor with index built in (so the index is checked once); JIT partially inlines struct-field mutation

Browse Source 
svn: r14530

original commit: 709ad23400dab6a39cf3499be13896434414d2fa
This commit is contained in:
Matthew Flatt 2009-04-16 19:01:20 +00:00
parent a6ef7af3bd
commit e1ff6bf405
2 changed files with 80 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

149
collects/mred/private/wxme/text.ss
View File

@ -384,7 +384,7 @@
(not (zero? how-close)) (not (zero? how-close))
((abs how-close) . > . between-threshold))]) ((abs how-close) . > . between-threshold))])
(let ([snip (and onit? (let ([snip (and onit?
(find-snip pos 'after))]) (do-find-snip pos 'after))])
(and snip (and snip
(let-boxes ([x 0.0] [y 0.0]) (let-boxes ([x 0.0] [y 0.0])
(get-snip-position-and-location snip #f x y) (get-snip-position-and-location snip #f x y)
@ -428,7 +428,7 @@
((abs how-close) . > . between-threshold))]) ((abs how-close) . > . between-threshold))])
(if onit? (if onit?
;; we're in the snip's horizontal region... ;; 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. ;; ... but maybe the mouse is above or below it.
(let-boxes ([top 0.0] (let-boxes ([top 0.0]
[bottom 0.0] [bottom 0.0]
@ -1332,7 +1332,7 @@
(let* ([gsnip (if (not did-one?) (let* ([gsnip (if (not did-one?)
(begin (begin
(make-snipset start start) (make-snipset start start)
(find-snip start 'after-or-none)) (do-find-snip start 'after-or-none))
before-snip)] before-snip)]
[before-snip (or before-snip gsnip)] [before-snip (or before-snip gsnip)]
[inserted-new-line? [inserted-new-line?
@ -1534,7 +1534,7 @@
[(or (equal? c #\newline) (equal? c #\tab)) [(or (equal? c #\newline) (equal? c #\tab))
(let ([newline? (equal? c #\newline)]) (let ([newline? (equal? c #\newline)])
(make-snipset (+ i start) (+ i start 1)) (make-snipset (+ i start) (+ i start 1))
(let ([snip (find-snip (+ i start) 'after)]) (let ([snip (do-find-snip (+ i start) 'after)])
(if newline? (if newline?
;; forced return - split the snip ;; forced return - split the snip
@ -1611,7 +1611,7 @@
(when (eq? (mline-last-snip (snip->line snip)) snip) (when (eq? (mline-last-snip (snip->line snip)) snip)
(set-mline-last-snip! (snip->line tabsnip) tabsnip)))))) (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)]) (let ([i (add1 i)])
(loop (+ i start) (loop (+ i start)
(if (= i addlen) #f (string-snip-buffer snip)) (if (= i addlen) #f (string-snip-buffer snip))
@ -1623,7 +1623,7 @@
[(cnt . > . MAX-COUNT-FOR-SNIP) [(cnt . > . MAX-COUNT-FOR-SNIP)
;; divide up snip, because it's too large: ;; divide up snip, because it's too large:
(make-snipset (+ i start) (+ i start)) (make-snipset (+ i start) (+ i start))
(let ([snip (find-snip (+ i start) 'after)]) (let ([snip (do-find-snip (+ i start) 'after)])
(loop (+ i start) (loop (+ i start)
(string-snip-buffer snip) (string-snip-buffer snip)
(add1 (string-snip-dtext snip)) (add1 (string-snip-dtext snip))
@ -1711,8 +1711,8 @@
(make-snipset start end) (make-snipset start end)
(set! revision-count (add1 revision-count)) (set! revision-count (add1 revision-count))
(let* ([start-snip (find-snip start 'before-or-none)] (let* ([start-snip (do-find-snip start 'before-or-none)]
[end-snip (find-snip end 'before)] [end-snip (do-find-snip end 'before)]
[with-undo? (and with-undo? [with-undo? (and with-undo?
(zero? s-noundomode))] (zero? s-noundomode))]
[rec (if with-undo? [rec (if with-undo?
@ -1956,8 +1956,8 @@
s-style-list)]) s-style-list)])
(set-common-copy-region-data! (get-region-data startp endp)) (set-common-copy-region-data! (get-region-data startp endp))
(let ([start (find-snip startp 'after)] (let ([start (do-find-snip startp 'after)]
[end (find-snip endp 'after-or-none)] [end (do-find-snip endp 'after-or-none)]
[wl? write-locked?] [wl? write-locked?]
[fl? flow-locked?]) [fl? flow-locked?])
@ -2050,7 +2050,7 @@
(let ([addpos (snip->count snip)]) (let ([addpos (snip->count snip)])
(insert snip read-insert) (insert snip read-insert)
(when data (when data
(let ([snip (find-snip read-insert 'after)]) (let ([snip (do-find-snip read-insert 'after)])
(set-snip-data snip data))) (set-snip-data snip data)))
(set! read-insert (+ read-insert addpos)))) (set! read-insert (+ read-insert addpos))))
@ -2300,8 +2300,8 @@
((clickback-end c) . > . start) ((clickback-end c) . > . start)
;; we're in the right horizontal region, but maybe the mouse ;; we're in the right horizontal region, but maybe the mouse
;; is above or below the clickback ;; is above or below the clickback
(let ([start (find-snip (clickback-start c) 'after)] (let ([start (do-find-snip (clickback-start c) 'after)]
[end (find-snip (clickback-end c) 'before)]) [end (do-find-snip (clickback-end c) 'before)])
(and start (and start
end end
(let-boxes ([top 0.0] (let-boxes ([top 0.0]
@ -2510,18 +2510,20 @@
(send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send s-style-list new-named-style "Standard" (send s-style-list basic-style))
(send mf ok?))))))] (send mf ok?))))))]
[(or (eq? format 'text) (eq? format 'text-force-cr)) [(or (eq? format 'text) (eq? format 'text-force-cr))
(let loop ([saved-cr? #f]) (let ([s (make-string 1024)])
(let ([l (read-string 256 f)]) (let loop ([saved-cr? #f])
(unless (eof-object? l) (let ([len (read-string! s f)])
(let ([l2 (if (equal? l "") (unless (eof-object? len)
l (let* ([s1 (if (= len (string-length s))
(if (equal? #\return (string-ref l (sub1 (string-length l)))) s
(substring l 0 (sub1 (string-length l))) (substring s 0 len))]
l))]) [s2 (if (equal? #\return (string-ref s1 (sub1 len)))
(insert (regexp-replace* #rx"\r\n" (substring s1 0 (sub1 len))
(if saved-cr? (string-append "\r" l2) l2) s1)])
"\n")) (insert (regexp-replace* #rx"\r\n"
(loop (not (eq? l l2))))))) (if saved-cr? (string-append "\r" s2) s2)
"\n"))
(loop (not (eq? s1 s2))))))))
#f])]) #f])])
(when fileerr? (when fileerr?
@ -2605,8 +2607,8 @@
len len
end) end)
start)]) start)])
(let ([start-snip (if (zero? len) #f (find-snip start 'after))] (let ([start-snip (if (zero? len) #f (do-find-snip start 'after))]
[end-snip (if (zero? len) #f (find-snip end 'after-or-none))]) [end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))])
(and (do-write-headers-footers f #t) (and (do-write-headers-footers f #t)
(write-snips-to-file f s-style-list #f start-snip end-snip #f this) (write-snips-to-file f s-style-list #f start-snip end-snip #f this)
(do-write-headers-footers f #f)))))) (do-write-headers-footers f #f))))))
@ -3524,7 +3526,7 @@
(cond (cond
[new-style new-style] [new-style new-style]
[caret-style (send s-style-list find-or-create-style caret-style delta)] [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))])))] (send s-style-list find-or-create-style (snip->style gsnip) delta))])))]
[else [else
(set! write-locked? #t) (set! write-locked? #t)
@ -3544,7 +3546,7 @@
(begin (begin
(set! initial-style-needed? #f) (set! initial-style-needed? #f)
(values snips #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) [(rec)
(and (zero? s-noundomode) (and (zero? s-noundomode)
(make-object style-change-record% start end (make-object style-change-record% start end
@ -4007,8 +4009,6 @@
(set! write-locked? #t) (set! write-locked? #t)
(set! flow-locked? #t) (set! flow-locked? #t)
(set-box! a-ptr #f)
(set-box! b-ptr #f)
(send snip split pos a-ptr b-ptr) (send snip split pos a-ptr b-ptr)
(set! read-locked? #f) (set! read-locked? #f)
@ -4071,7 +4071,8 @@
(splice-snip snip prev next) (splice-snip snip prev next)
(set! snip-count (add1 snip-count)) (set! snip-count (add1 snip-count))
(insert-snip snip ins-snip) (insert-snip snip ins-snip)
(extra snip) (when extra
(extra snip))
(snip-set-admin snip snip-admin) (snip-set-admin snip snip-admin)
(snip-set-admin ins-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)]) (let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)])
(when snip (when snip
(unless (= s-pos start) (unless (= s-pos start)
(split-one start s-pos snip void))))) (split-one start s-pos snip #f)))))
(when (positive? end) (when (positive? end)
(let-values ([(snip s-pos) (find-snip/pos end 'before)]) (let-values ([(snip s-pos) (find-snip/pos end 'before)])
(unless (= (+ s-pos (snip->count snip)) end) (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) (define/private (insert-text-snip start style)
(let* ([snip (on-new-string-snip)] (let* ([snip (on-new-string-snip)]
@ -4257,6 +4258,11 @@
#f #f
snips)) 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] (def/public (find-snip [exact-nonnegative-integer? p]
[(symbol-in before-or-none before after after-or-none) direction] [(symbol-in before-or-none before after after-or-none) direction]
[maybe-box? [s-pos #f]]) [maybe-box? [s-pos #f]])
@ -4270,48 +4276,49 @@
(cond (cond
[(and (eq? direction 'before-or-none) (zero? p)) [(and (eq? direction 'before-or-none) (zero? p))
(values #f 0)] (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 [else
(let* ([line (mline-find-position (unbox line-root-box) p)] (let* ([line (mline-find-position (unbox line-root-box) p)]
[pos (mline-get-position line)] [pos (mline-get-position line)]
[p (- p pos)]) [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 loop ([snip snip]
(let ([snip (mline-snip line)]) [pos pos]
(if (and (zero? p) (snip->prev snip)) [p p])
;; back up one: (if snip
(let ([snip (snip->prev snip)]) (let ([p (- p (snip->count snip))])
(values snip (cond
(- pos (snip->count snip)) [(or (and (eq? direction 'on)
(+ p (snip->count snip)))) (zero? p))
(values snip pos p)))]) (and (or (eq? direction 'before)
(eq? direction 'before-or-none))
(let loop ([snip snip] (p . <= . 0))
[pos pos] (and (or (eq? direction 'after)
[p p]) (eq? direction 'after-or-none))
(if snip (p . < . 0)))
(let ([p (- p (snip->count snip))]) (values snip pos)]
(cond [(and (eq? direction 'on)
[(or (and (eq? direction 'on) (p . < . 0))
(zero? p)) (values #f 0)]
(and (or (eq? direction 'before) [else
(eq? direction 'before-or-none)) (loop (snip->next snip) (+ pos (snip->count snip)) p)]))
(p . <= . 0)) (if (not (eq? direction 'after-or-none))
(and (or (eq? direction 'after) (values last-snip (- pos (snip->count last-snip)))
(eq? direction 'after-or-none)) (values #f 0)))))))]))
(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]) (def/public (find-next-non-string-snip [(make-or-false snip%) snip])
(if (or (and snip (if (or (and snip

3
collects/mred/private/wxme/undo.ss
View File

@ -4,7 +4,8 @@
"snip.ss" "snip.ss"
"snip-flags.ss") "snip-flags.ss")
(provide proc-record% (provide change-record%
proc-record%
unmodify-record% unmodify-record%
insert-record% insert-record%
insert-snip-record% insert-snip-record%