From d5024cf595add0d7b5867724c47d08acced5142c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 28 May 2020 09:35:56 -0600 Subject: [PATCH] schemify: keep simple loop patterrns intact In Schemify's lifting pass, avoid disturbing loop patterns that Chez Scheme will recognize. Keeping the loops intact is helpful for floating-point unboxing, where (currently) unbxoing is supported across loop iterations but not across function boundaries in general. --- pkgs/base/info.rkt | 2 +- .../racket-test-core/tests/racket/flonum.rktl | 4 + racket/src/cs/compile-file.ss | 2 +- racket/src/cs/convert.rkt | 2 +- racket/src/cs/linklet.sls | 4 +- racket/src/cs/rumble/flvector.ss | 24 +-- racket/src/expander/compile/form.rkt | 17 +- racket/src/racket/src/schvers.h | 2 +- racket/src/racket/src/startup.inc | 12 +- racket/src/schemify/lift.rkt | 192 +++++++++++++++++- 10 files changed, 224 insertions(+), 37 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 7c98ed3e43..81eee47c19 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "7.7.0.6") +(define version "7.7.0.7") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-test-core/tests/racket/flonum.rktl b/pkgs/racket-test-core/tests/racket/flonum.rktl index 02ff404dd8..4fcf33de26 100644 --- a/pkgs/racket-test-core/tests/racket/flonum.rktl +++ b/pkgs/racket-test-core/tests/racket/flonum.rktl @@ -26,6 +26,10 @@ (define (same-results fl unsafe-fl args) (test (apply fl args) apply unsafe-fl args)) + (for ([line (in-list 1nary-table)]) + (test #t 'single (and ((car line) +nan.0) #t)) + (test #t 'single (and ((cadr line) +nan.0) #t))) + (for ([ignore (in-range 0 800)]) (let ([i (random)] [j (random)] diff --git a/racket/src/cs/compile-file.ss b/racket/src/cs/compile-file.ss index 5e3bbb56f1..f043280d23 100644 --- a/racket/src/cs/compile-file.ss +++ b/racket/src/cs/compile-file.ss @@ -2,7 +2,7 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. (define-values (need-maj need-min need-sub need-dev) - (values 9 5 3 28)) + (values 9 5 3 29)) (unless (guard (x [else #f]) (eval 'scheme-fork-version-number)) (error 'compile-file diff --git a/racket/src/cs/convert.rkt b/racket/src/cs/convert.rkt index da184f2959..061e8e7676 100644 --- a/racket/src/cs/convert.rkt +++ b/racket/src/cs/convert.rkt @@ -120,7 +120,7 @@ ;; Lift functions to avoid closure creation: (define lifted-body (time - (lift-in-schemified-body body))) + (lift-in-schemified-body body #t))) (append (for/list ([p (in-list lifted-constants)]) (cons 'define p)) lifted-body))) diff --git a/racket/src/cs/linklet.sls b/racket/src/cs/linklet.sls index 358720b367..9141521726 100644 --- a/racket/src/cs/linklet.sls +++ b/racket/src/cs/linklet.sls @@ -587,7 +587,9 @@ (lambda (key) (values #f #f #f))) import-keys)) (define impl-lam/lifts - (lift-in-schemified-linklet (show pre-lift-on? "pre-lift" impl-lam))) + (lift-in-schemified-linklet (show pre-lift-on? "pre-lift" impl-lam) + ;; preserve loop forms? + (not (eq? linklet-compilation-mode 'interp)))) (define impl-lam/jitified (cond [(not jitify-mode?) impl-lam/lifts] diff --git a/racket/src/cs/rumble/flvector.ss b/racket/src/cs/rumble/flvector.ss index 98733cdb64..9c6f5e6578 100644 --- a/racket/src/cs/rumble/flvector.ss +++ b/racket/src/cs/rumble/flvector.ss @@ -59,14 +59,12 @@ (unless (and (>= pos 0) (< pos len)) (raise-range-error who "flvector" "" pos flvec 0 len))) - (bytevector-ieee-double-ref (flvector-bstr flvec) - (bitwise-arithmetic-shift-left pos 3) - (native-endianness))) + (bytevector-ieee-double-native-ref (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3))) (define (unsafe-flvector-ref flvec pos) - (#3%bytevector-ieee-double-ref (flvector-bstr flvec) - (#3%fxsll pos 3) - (native-endianness))) + (#3%bytevector-ieee-double-native-ref (flvector-bstr flvec) + (#3%fxsll pos 3))) (define/who (flvector-set! flvec pos val) (check who flvector? flvec) @@ -76,16 +74,14 @@ (< pos len)) (raise-range-error who "flvector" "" pos flvec 0 len))) (check who flonum? val) - (bytevector-ieee-double-set! (flvector-bstr flvec) - (bitwise-arithmetic-shift-left pos 3) - val - (native-endianness))) + (bytevector-ieee-double-native-set! (flvector-bstr flvec) + (bitwise-arithmetic-shift-left pos 3) + val)) (define (unsafe-flvector-set! flvec pos val) - (#3%bytevector-ieee-double-set! (flvector-bstr flvec) - (#3%fxsll pos 3) - val - (native-endianness))) + (#3%bytevector-ieee-double-native-set! (flvector-bstr flvec) + (#3%fxsll pos 3) + val)) (define/who flvector-copy (case-lambda diff --git a/racket/src/expander/compile/form.rkt b/racket/src/expander/compile/form.rkt index b59b6404be..5bbc1f17de 100644 --- a/racket/src/expander/compile/form.rkt +++ b/racket/src/expander/compile/form.rkt @@ -355,20 +355,23 @@ ;; ---------------------------------------- ;; Handle the `define-syntaxes`-with-zero-results hack for the top level; -;; beware that we make two copies of `finish` +;; beware that we may make two copies of `finish`, and we assume that `finish` +;; is a `begin` form (define (generate-top-level-define-syntaxes gen-syms rhs transformer-set!s finish) `(call-with-values (lambda () ,rhs) (case-lambda - [,gen-syms - (begin - ,@transformer-set!s - ,finish - (void))] + ,@(if (null? gen-syms) ; avoid unnecessary duplication if no `gen-syms` + '() + `([,gen-syms + (begin + ,@transformer-set!s + ,@(cdr finish) + (void))])) [() (let-values ([,gen-syms (values ,@(for/list ([s (in-list gen-syms)]) `'#f))]) (begin - ,finish + ,@(cdr finish) (void)))] [args ;; Provoke the wrong-number-of-arguments error: diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index bebb82ed88..cf9aadaaee 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 7 #define MZSCHEME_VERSION_Y 7 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 6 +#define MZSCHEME_VERSION_W 7 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 21472801ce..03a93ec7ac 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -33942,9 +33942,13 @@ static const char *startup_source = "(list" " 'call-with-values" "(list 'lambda '() rhs_0)" -"(list" +"(list*" " 'case-lambda" -"(list gen-syms_0(list* 'begin(qq-append transformer-set!s_0(list* finish_0 '((void))))))" +"(qq-append" +"(if(null? gen-syms_0)" +" '()" +"(list(list gen-syms_0(list* 'begin(qq-append transformer-set!s_0(qq-append(cdr finish_0) '((void))))))))" +"(list" "(list" " '()" "(list" @@ -33977,8 +33981,8 @@ static const char *startup_source = " for-loop_0)" " null" " lst_0)))))))" -"(list* 'begin finish_0 '((void)))))" -"(list 'args(list* 'let-values(list(list* gen-syms_0 '((apply values args)))) '((void)))))))))" +"(list* 'begin(qq-append(cdr finish_0) '((void))))))" +"(list 'args(list* 'let-values(list(list* gen-syms_0 '((apply values args)))) '((void)))))))))))" "(define-values" "(propagate-inline-property)" "(lambda(e_0 orig-s_0)" diff --git a/racket/src/schemify/lift.rkt b/racket/src/schemify/lift.rkt index 4b0f92bc55..92bc96e24c 100644 --- a/racket/src/schemify/lift.rkt +++ b/racket/src/schemify/lift.rkt @@ -51,13 +51,13 @@ ;; bound-variable sets (define empty-frees+binds (cons #hasheq() #hasheq())) -(define (lift-in-schemified-linklet v) +(define (lift-in-schemified-linklet v [leave-loops-intact? #f]) ;; Match outer shape of a linklet produced by `schemify-linklet` ;; and lift in the linklet body: (let loop ([v v]) (match v [`(lambda ,args . ,body) - (define new-body (lift-in-schemified-body body)) + (define new-body (lift-in-schemified-body body leave-loops-intact?)) (if (for/and ([old (in-list body)] [new (in-list new-body)]) (eq? old new)) @@ -69,11 +69,11 @@ v `(let* ,bindings ,new-body))]))) -(define (lift-in-schemified-body body) +(define (lift-in-schemified-body body [leave-loops-intact? #f]) (for/list ([v (in-list body)]) - (lift-in-schemified v))) + (lift-in-schemified v leave-loops-intact?))) -(define (lift-in-schemified v) +(define (lift-in-schemified v leave-loops-intact?) ;; Quick pre-check: do any lifts appear to be possible? (define (lift-in? v) (match v @@ -186,9 +186,12 @@ (define lifts (make-hasheq)) (define locals (add-args args #hasheq())) (define frees+binds/ignored (compute-seq-lifts! body empty-frees+binds lifts locals)) + (define loops (if leave-loops-intact? + (find-seq-loops body lifts #hasheq() #hasheq()) + #hasheq())) (let ([lifts (if (zero? (hash-count lifts)) lifts - (close-and-convert-lifts lifts))]) + (close-and-convert-lifts lifts loops))]) (cond [(zero? (hash-count lifts)) v] [else @@ -418,13 +421,137 @@ [frees+binds (compute-seq-lifts! body frees+binds lifts locals)]) (remove-frees/add-binds ids frees+binds lifts))])) + ;; ---------------------------------------- + ;; Pass 1b (optonal): find loops that don't need to be lifted, + ;; on the assumption they'll be recognized as loops + + ;; Returns updated `loops` table + (define (find-loops v lifts loop-if-tail loops) + (match v + [`(letrec . ,_) + (find-letrec-loops v lifts loop-if-tail loops)] + [`(letrec* . ,_) + (find-letrec-loops v lifts loop-if-tail loops)] + [`((letrec ([,id ,rhs]) ,rator) ,rands ...) + (find-loops `(letrec ([,id ,rhs]) (,rator . ,rands)) lifts loop-if-tail loops)] + [`((letrec* ([,id ,rhs]) ,rator) ,rands ...) + (find-loops `(letrec ([,id ,rhs]) (,rator . ,rands)) lifts loop-if-tail loops)] + [`(let . ,_) + (find-let-loops v lifts loop-if-tail loops)] + [`(lambda ,args . ,body) + (find-loops body lifts #hasheq() loops)] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([loops loops]) ([body (in-list bodys)]) + (find-loops body lifts #hasheq() loops))] + [`(begin . ,vs) + (find-seq-loops vs lifts loop-if-tail loops)] + [`(begin0 ,v . ,vs) + (define new-loops (find-loops v lifts #hasheq() loops)) + (if (null? vs) + new-loops + (find-seq-loops vs lifts #hasheq() new-loops))] + [`(quote . ,_) loops] + [`(if ,tst ,thn ,els) + (let* ([loops (find-loops tst lifts #hasheq() loops)] + [loops (find-loops thn lifts loop-if-tail loops)] + [loops (find-loops els lifts loop-if-tail loops)]) + loops)] + [`(with-continuation-mark* ,_ ,key ,val ,body) + (let* ([loops (find-loops key lifts #hasheq() loops)] + [loops (find-loops val lifts #hasheq() loops)]) + (find-loops body lifts loop-if-tail loops))] + [`(set! ,id ,rhs) + (find-loops rhs lifts #hasheq() loops)] + [`(#%variable-reference . ,_) + (error 'internal-error "lift: unexpected variable reference")] + [`(call-with-values ,producer ,consumer) + (let ([loops (find-loops producer lifts #hasheq() loops)]) + (find-loops-in-tail-called consumer lifts loop-if-tail loops))] + [`(,rator . ,rands) + (define f (unwrap rator)) + (let ([loops + (cond + [(and (symbol? f) + (hash-ref loop-if-tail f #f)) + => (lambda (bx) + (set-box! bx #t) ; record reference to loop + loops)] + [else (find-loops rator lifts #hasheq() loops)])]) + (for/fold ([loops loops]) ([rand (in-list rands)]) + (find-loops rand lifts #hasheq() loops)))] + [`,_ + (define x (unwrap v)) + (if (symbol? x) + (hash-remove loops x) + loops)])) + + (define (find-seq-loops vs lifts loop-if-tail loops) + (let loop ([vs vs] [loops loops]) + (cond + [(wrap-null? (wrap-cdr vs)) + (find-loops (wrap-car vs) lifts loop-if-tail loops)] + [else + (loop (wrap-cdr vs) + (find-loops (wrap-car vs) lifts #hasheq() loops))]))) + + (define (find-let-loops v lifts loop-if-tail loops) + (match v + [`(,_ ([,_ ,rhss] ...) . ,body) + (define new-loops + (for/fold ([loops loops]) ([rhs (in-list rhss)]) + (find-loops rhs lifts #hasheq() loops))) + (find-seq-loops body lifts loop-if-tail new-loops)])) + + (define (find-letrec-loops v lifts loop-if-tail loops) + (match v + [`(,_ ([,id ,rhs]) (,id2 . ,rands)) + (define u-id (unwrap id)) + (cond + [(and (eq? (unwrap id2) u-id) + (hash-ref lifts u-id #f)) + ;; It's liftable, so potentially a loop + (let* ([loops (hash-set loops u-id #t)] + [loops (for/fold ([loops loops]) ([rand (in-list rands)]) + (find-loops rand lifts #hasheq() loops))]) + (cond + [(not (hash-ref loops u-id #f)) + (find-loops rhs #hasheq() loops)] + [else + (define new-loop-if-tail + (hash-set (for/hasheq ([(id bx) (in-hash loop-if-tail)]) + (values id (box #f))) + u-id (box #f))) + (define new-loops + (find-loops-in-tail-called rhs lifts new-loop-if-tail loops)) + (cond + [(hash-ref new-loops u-id #f) + new-loops] + [else + ;; Not a loop, so any reference added in `new-loop-if-tail` + ;; is also to a non-loop + (for/fold ([loops new-loops]) ([(id bx) (in-hash new-loop-if-tail)]) + (if (unbox bx) + (hash-remove loops id) + loops))])]))] + [else (find-let-loops v lifts loop-if-tail loops)])] + [`,_ (find-let-loops v lifts loop-if-tail loops)])) + + (define (find-loops-in-tail-called v lifts loop-if-tail loops) + (match v + [`(lambda ,args . ,body) + (find-seq-loops body lifts loop-if-tail loops)] + [`(case-lambda [,argss . ,bodys] ...) + (for/fold ([loops loops]) ([body (in-list bodys)]) + (find-seq-loops body lifts loop-if-tail loops))] + [`,_ (find-loops v lifts #hasheq() loops)])) + ;; ---------------------------------------- ;; Bridge between pass 1 and 2: transitive closure of free variables ;; Close a liftable's free variables over other variables needed by ;; other lifted functions that it calls. Also, clear `mutated` and ;; `var-ref` information from `lifts` in the returned table. - (define (close-and-convert-lifts lifts) + (define (close-and-convert-lifts lifts loops) (define new-lifts (make-hasheq)) ;; Copy over `liftable`s: (for ([(f info) (in-hash lifts)]) @@ -485,6 +612,9 @@ (for ([(f info) (in-hash lifts)]) (when (eq? info '#:empty) (hash-set! new-lifts f info))) + ;; Remove any loops, which should be left alone after all + (for ([f (in-hash-keys loops)]) + (hash-remove! new-lifts f)) ;; Return new lifts new-lifts) @@ -769,3 +899,51 @@ (with-deterministic-gensym (lift-in v)) v)) + +;; ============================================================ + +(module+ main + (require racket/pretty) + (pretty-print + (lift-in-schemified-linklet + '(lambda () + (define f0 + (lambda () + (letrec ([loop (lambda (x) + (if (zero? x) + (let ([z 0]) + z) + (call-with-values + (lambda () (values 1 10)) + (lambda (v1 v2) + (loop (sub1 x))))))]) + (loop 8)))) + (define f0 + (lambda () + (letrec ([l1 (lambda (x) + (if (zero? x) + 'done + (letrec ([l2 (lambda (y) + (if (zero? y) + (l1 (sub1 x)) + (l2 (sub1 y))))]) + (l2 10))))]) + (l1 8)))) + (define f2 + (lambda () + (letrec ([not-a-loop (lambda (x) + (if (zero? x) + 0 + (add1 (not-a-loop (sub1 x)))))]) + (not-a-loop 8)))) + (define f3 + (lambda () + (letrec ([nl1 (lambda (x) + (if (zero? x) + 0 + (letrec ([nl2 (lambda (y) + (nl1 (nl2 (sub1 x))))]) + (nl2 10))))]) + (nl1 8)))) + 10) + #t)))