diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 9f14bf29be..2b297eaa49 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -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 diff --git a/collects/mred/private/wxme/undo.ss b/collects/mred/private/wxme/undo.ss index 15f44fbdc3..053b3f82fe 100644 --- a/collects/mred/private/wxme/undo.ss +++ b/collects/mred/private/wxme/undo.ss @@ -4,7 +4,8 @@ "snip.ss" "snip-flags.ss") -(provide proc-record% +(provide change-record% + proc-record% unmodify-record% insert-record% insert-snip-record% diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a9040846b5..bf852444a1 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -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)))))))))))))))) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 700c6f4af9..ce2e21c67a 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -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();