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

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

@ -139,23 +139,33 @@
v]))
(define region-times (make-eq-hashtable))
(define region-gc-times (make-eq-hashtable))
(define region-counts (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
(syntax-rules ()
[(_ label e ...) (measure-performance-region label (lambda () e ...))]))
(define (measure-performance-region label thunk)
(cond
[measure-performance?
(let ([old-start current-start-time])
(set! current-start-time (current-inexact-milliseconds))
(set! current-start-time (cons (current-inexact-milliseconds) current-start-time))
(set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time))
(begin0
(thunk)
(let ([delta (- (current-inexact-milliseconds) current-start-time)])
(let ([delta (- (current-inexact-milliseconds) (car current-start-time))]
[gc-delta (- (current-gc-milliseconds) (car current-gc-start-time))])
(hashtable-update! region-times label (lambda (v) (+ v delta)) 0)
(hashtable-update! region-gc-times label (lambda (v) (+ v gc-delta)) 0)
(hashtable-update! region-counts label add1 0)
(set! current-start-time (+ old-start delta)))))]
(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)]))
(define (add-performance-memory! label delta)
(when measure-performance?
@ -168,14 +178,15 @@
(define (linklet-performance-report!)
(when measure-performance?
(let ([total 0])
(define (report label n units extra)
(define (pad v w)
(let ([s (chez:format "~a" v)])
(string-append (make-string (max 0 (- w (string-length s))) #\space)
s)))
(chez:printf ";; ~a: ~a ~a~a\n"
(define (report label n n-extra units extra)
(chez:printf ";; ~a: ~a~a ~a~a\n"
(pad label 15)
(pad (round (inexact->exact n)) 5)
n-extra
units
extra))
(define (ht->sorted-list ht)
@ -185,14 +196,17 @@
(let ([label (car p)]
[n (cdr p)])
(set! total (+ total n))
(report label n 'ms (let ([c (hashtable-ref region-counts label 0)])
(report label n
(chez:format " [~a]" (pad (hashtable-ref region-gc-times label 0) 5))
'ms
(let ([c (hashtable-ref region-counts label 0)])
(if (zero? c)
""
(chez:format " ; ~a times" c))))))
(ht->sorted-list region-times))
(report 'total total 'ms "")
(report 'total total "" 'ms "")
(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)))))
;; `compile`, `interpret`, etc. have `dynamic-wind`-based state
@ -387,6 +401,8 @@
(cond
[(not jitify-mode?) impl-lam/lifts]
[else
(performance-region
'jitify
(jitify-schemified-linklet (case linklet-compilation-mode
[(jit) (show pre-jit-on? "pre-jitified" impl-lam/lifts)]
[else (show "schemified" impl-lam/lifts)])
@ -414,7 +430,7 @@
(show lambda-on? "lambda" (correlated->annotation expr)))])
(if serializable?
(make-wrapped-code code arity-mask name)
code))))]))]))
code))))])))]))
(define impl-lam/interpable
(let ([impl-lam (case (and jitify-mode?
linklet-compilation-mode)

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

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

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

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