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

schemify: speed up jitify a little

Browse Source
This commit is contained in:
Matthew Flatt 2018-06-22 18:57:33 -06:00
parent ec036a0f5f
commit d72b70f8e1
3 changed files with 77 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
racket/src/cs/linklet.sls
View File

@ -139,23 +139,33 @@
v])) v]))
(define region-times (make-eq-hashtable)) (define region-times (make-eq-hashtable))
(define region-gc-times (make-eq-hashtable))
(define region-counts (make-eq-hashtable)) (define region-counts (make-eq-hashtable))
(define region-memories (make-eq-hashtable)) (define region-memories (make-eq-hashtable))
(define current-start-time 0) (define current-start-time '())
(define current-gc-start-time '())
(define-syntax performance-region (define-syntax performance-region
(syntax-rules () (syntax-rules ()
[(_ label e ...) (measure-performance-region label (lambda () e ...))])) [(_ label e ...) (measure-performance-region label (lambda () e ...))]))
(define (measure-performance-region label thunk) (define (measure-performance-region label thunk)
(cond (cond
[measure-performance? [measure-performance?
(let ([old-start current-start-time]) (set! current-start-time (cons (current-inexact-milliseconds) current-start-time))
(set! current-start-time (current-inexact-milliseconds)) (set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time))
(begin0 (begin0
(thunk) (thunk)
(let ([delta (- (current-inexact-milliseconds) current-start-time)]) (let ([delta (- (current-inexact-milliseconds) (car current-start-time))]
(hashtable-update! region-times label (lambda (v) (+ v delta)) 0) [gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))])
(hashtable-update! region-counts label add1 0) (hashtable-update! region-times label (lambda (v) (+ v delta)) 0)
(set! current-start-time (+ old-start delta)))))] (hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0)
(hashtable-update! region-counts label add1 0)
(set! current-start-time (cdr current-start-time))
(set! current-gc-start-time (cdr current-gc-start-time))
(let loop ([l current-start-time] [gc-l current-gc-start-time])
(unless (null? l)
(set-car! l (+ (car l) delta))
(set-car! gc-l (+ (car gc-l) gc-delta))
(loop (cdr l) (cdr gc-l))))))]
[else (thunk)])) [else (thunk)]))
(define (add-performance-memory! label delta) (define (add-performance-memory! label delta)
(when measure-performance? (when measure-performance?
@ -168,14 +178,15 @@
(define (linklet-performance-report!) (define (linklet-performance-report!)
(when measure-performance? (when measure-performance?
(let ([total 0]) (let ([total 0])
(define (report label n units extra) (define (pad v w)
(define (pad v w) (let ([s (chez:format "~a" v)])
(let ([s (chez:format "~a" v)]) (string-append (make-string (max 0 (- w (string-length s))) #\space)
(string-append (make-string (max 0 (- w (string-length s))) #\space) s)))
s))) (define (report label n n-extra units extra)
(chez:printf ";; ~a: ~a ~a~a\n" (chez:printf ";; ~a: ~a~a ~a~a\n"
(pad label 15) (pad label 15)
(pad (round (inexact->exact n)) 5) (pad (round (inexact->exact n)) 5)
n-extra
units units
extra)) extra))
(define (ht->sorted-list ht) (define (ht->sorted-list ht)
@ -185,14 +196,17 @@
(let ([label (car p)] (let ([label (car p)]
[n (cdr p)]) [n (cdr p)])
(set! total (+ total n)) (set! total (+ total n))
(report label n 'ms (let ([c (hashtable-ref region-counts label 0)]) (report label n
(if (zero? c) (chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) 5))
"" 'ms
(chez:format " ; ~a times" c)))))) (let ([c (hashtable-ref region-counts label 0)])
(if (zero? c)
""
(chez:format " ; ~a times" c))))))
(ht->sorted-list region-times)) (ht->sorted-list region-times))
(report 'total total 'ms "") (report 'total total "" 'ms "")
(chez:printf ";;\n") (chez:printf ";;\n")
(for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) 'MB "")) (for-each (lambda (p) (report (car p) (/ (cdr p) 1024 1024) "" 'MB ""))
(ht->sorted-list region-memories))))) (ht->sorted-list region-memories)))))
;; `compile`, `interpret`, etc. have `dynamic-wind`-based state ;; `compile`, `interpret`, etc. have `dynamic-wind`-based state
@ -387,26 +401,28 @@
(cond (cond
[(not jitify-mode?) impl-lam/lifts] [(not jitify-mode?) impl-lam/lifts]
[else [else
(jitify-schemified-linklet (case linklet-compilation-mode (performance-region
[(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)] 'jitify
[else (show "schemified" impl-lam/lifts)]) (jitify-schemified-linklet (case linklet-compilation-mode
;; don't need extract for non-serializable 'lambda mode [(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)]
(or serializable? (eq? linklet-compilation-mode 'jit)) [else (show "schemified" impl-lam/lifts)])
;; need lift only for serializable JIT mode ;; don't need extract for non-serializable 'lambda mode
(and serializable? (eq? linklet-compilation-mode 'jit)) (or serializable? (eq? linklet-compilation-mode 'jit))
;; compilation threshold for ahead-of-time mode: ;; need lift only for serializable JIT mode
(and (eq? linklet-compilation-mode 'mach) (and serializable? (eq? linklet-compilation-mode 'jit))
linklet-compilation-limit) ;; compilation threshold for ahead-of-time mode:
;; correlation -> lambda (and (eq? linklet-compilation-mode 'mach)
(case linklet-compilation-mode linklet-compilation-limit)
[(jit) ;; correlation -> lambda
;; Preserve annotated `lambda` source for on-demand compilation: (case linklet-compilation-mode
(lambda (expr arity-mask name) [(jit)
(make-wrapped-code (correlated->annotation (xify expr)) ;; Preserve annotated `lambda` source for on-demand compilation:
arity-mask (lambda (expr arity-mask name)
name))] (make-wrapped-code (correlated->annotation (xify expr))
[else arity-mask
;; Compile an individual `lambda`: name))]
[else
;; Compile an individual `lambda`:
(lambda (expr arity-mask name) (lambda (expr arity-mask name)
(performance-region (performance-region
'compile 'compile
@ -414,7 +430,7 @@
(show lambda-on? "lambda" (correlated->annotation expr)))]) (show lambda-on? "lambda" (correlated->annotation expr)))])
(if serializable? (if serializable?
(make-wrapped-code code arity-mask name) (make-wrapped-code code arity-mask name)
code))))]))])) code))))])))]))
(define impl-lam/interpable (define impl-lam/interpable
(let ([impl-lam (case (and jitify-mode? (let ([impl-lam (case (and jitify-mode?
linklet-compilation-mode) linklet-compilation-mode)

14
racket/src/schemify/jitify.rkt
View File

@ -31,6 +31,8 @@
(provide jitify-schemified-linklet) (provide jitify-schemified-linklet)
(struct convert-mode (sizes called? lift? no-more-conversions?))
(define lifts-id (gensym 'jits)) (define lifts-id (gensym 'jits))
(define (jitify-schemified-linklet v (define (jitify-schemified-linklet v
@ -132,16 +134,10 @@
(match v (match v
[`(lambda ,args . ,body) [`(lambda ,args . ,body)
(define new-body (jitify-schemified-body body (plain-add-args env args))) (define new-body (jitify-schemified-body body (plain-add-args env args)))
(if (for/and ([old (in-list body)] (reannotate v `(lambda ,args . ,new-body))]
[new (in-list new-body)])
(eq? old new))
v
(reannotate v `(lambda ,args . ,new-body)))]
[`(let* ,bindings ,body) [`(let* ,bindings ,body)
(define new-body (loop body (add-bindings env bindings))) (define new-body (loop body (add-bindings env bindings)))
(if (eq? body new-body) (reannotate v `(let* ,bindings ,new-body))])))
v
(reannotate v `(let* ,bindings ,new-body)))])))
(define (jitify-schemified-body body env) (define (jitify-schemified-body body env)
(define top-env (define top-env
@ -678,8 +674,6 @@
;; If there's a size threshold, then a convert mode is a ;; If there's a size threshold, then a convert mode is a
;; `convert-mode` instance. ;; `convert-mode` instance.
(struct convert-mode (sizes called? lift? no-more-conversions?))
(define (init-convert-mode v) (define (init-convert-mode v)
(cond (cond
[convert-size-threshold [convert-size-threshold

21
racket/src/schemify/lift.rkt
View File

@ -369,17 +369,19 @@
(define (compute-letrec-lifts! v frees+binds lifts locals) (define (compute-letrec-lifts! v frees+binds lifts locals)
(match v (match v
[`(,_ ([,ids ,rhss] ...) . ,body) [`(,_ ([,ids ,rhss] ...) . ,body)
(define all-lambda? (define all-lambda-or-immediate?
(for/and ([rhs (in-list rhss)]) (for/and ([rhs (in-list rhss)])
(lambda? rhs))) (or (lambda? rhs)
(when all-lambda? (immediate? rhs))))
(when all-lambda-or-immediate?
;; Each RHS is a candidate for lifting ;; Each RHS is a candidate for lifting
(for ([id (in-list ids)] (for ([id (in-list ids)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(hash-set! lifts (unwrap id) (liftable rhs #f #f)))) (when (lambda? rhs)
(let* ([rhs-locals (add-args ids locals (if all-lambda? 'ready 'early))] (hash-set! lifts (unwrap id) (liftable rhs #f #f)))))
(let* ([rhs-locals (add-args ids locals (if all-lambda-or-immediate? 'ready 'early))]
[frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts rhs-locals)] [frees+binds (compute-rhs-lifts! ids rhss frees+binds lifts rhs-locals)]
[locals (if all-lambda? [locals (if all-lambda-or-immediate?
rhs-locals rhs-locals
(add-args ids locals))] (add-args ids locals))]
[frees+binds (compute-seq-lifts! body frees+binds lifts locals)]) [frees+binds (compute-seq-lifts! body frees+binds lifts locals)])
@ -607,6 +609,13 @@
[`(case-lambda . ,_) #t] [`(case-lambda . ,_) #t]
[`,_ #f])) [`,_ #f]))
(define (immediate? v)
(match v
[`(quote . ,_) #t]
[`(,_ . ,_) #f]
[`,_
(not (symbol? (unwrap v)))]))
(define (consistent-argument-count? proc n) (define (consistent-argument-count? proc n)
(define (consistent? args n) (define (consistent? args n)
(let loop ([args args] [n n]) (let loop ([args args] [n n])