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

@@ -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]))

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)]

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

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)))

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]

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)
+  (bytevector-ieee-double-native-ref (flvector-bstr flvec)
-                              (bitwise-arithmetic-shift-left pos 3)
+                                     (bitwise-arithmetic-shift-left pos 3)))
-                              (native-endianness)))
 
 (define (unsafe-flvector-ref flvec pos)
-  (#3%bytevector-ieee-double-ref (flvector-bstr flvec)
+  (#3%bytevector-ieee-double-native-ref (flvector-bstr flvec)
-                                 (#3%fxsll pos 3)
+                                        (#3%fxsll pos 3)))
-                                 (native-endianness)))
 
 (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)
+  (bytevector-ieee-double-native-set! (flvector-bstr flvec)
-                               (bitwise-arithmetic-shift-left pos 3)
+                                      (bitwise-arithmetic-shift-left pos 3)
-                               val
+                                      val))
-                               (native-endianness)))
 
 (define (unsafe-flvector-set! flvec pos val)
-  (#3%bytevector-ieee-double-set! (flvector-bstr flvec)
+  (#3%bytevector-ieee-double-native-set! (flvector-bstr flvec)
-                                  (#3%fxsll pos 3)
+                                         (#3%fxsll pos 3)
-                                  val
+                                         val))
-                                  (native-endianness)))
 
 (define/who flvector-copy
   (case-lambda

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
+      ,@(if (null? gen-syms) ; avoid unnecessary duplication if no `gen-syms`
-       (begin
+            '()
-         ,@transformer-set!s
+            `([,gen-syms
-         ,finish
+               (begin
-         (void))]
+                 ,@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:

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

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* 'begin(qq-append(cdr finish_0) '((void))))))"
-"(list 'args(list* 'let-values(list(list* gen-syms_0 '((apply values args)))) '((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)"

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)))