improve loop detection

mats/fl.ms

@@ -1313,6 +1313,55 @@
                                  (fl+ v)
                                  (loop (fx- n 1) (fl+ v 1.0))))))
 
+  (check-loop-allocation (lambda (v)
+                           ;; check that a `let` around the initial call into a
+                           ;; loop is recognized by the lop-detection pass, which
+                           ;; in turn enables flonum unboxing
+                           (letrec ([loop (lambda (n v)
+                                            (if (fx= n 0)
+                                                (fl+ v)
+                                                (loop (fx- n 1) (fl+ v 1.0))))])
+                             (let ([v (fl+ v v)])
+                               ((black-box void))
+                               (loop 100 (fl+ v v))))))
+
+  (check-loop-allocation (lambda (v)
+                           ;; check that a loop entry can be nested in a call
+                           (letrec ([loop (lambda (n v)
+                                            (if (fx= n 0)
+                                                (fl+ v)
+                                                (loop (fx- n 1) (fl+ v 1.0))))])
+                             ((black-box (lambda (x y) x))
+                              ((black-box (lambda (x y z) z))
+                               'skip
+                               'skip-too
+                               (loop 100 (fl+ v)))
+                              'skip))))
+
+  (check-loop-allocation (lambda (v)
+                           ;; check that two loops can work
+                           (letrec ([loop (lambda (n v)
+                                            (if (fx= n 0)
+                                                (fl+ v)
+                                                (loop (fx- n 1) (fl+ v 1.0))))])
+                             (letrec ([loop2 (lambda (n v)
+                                               (if (fx= n 0)
+                                                   v
+                                                   (loop2 (fx- n 1) v)))])
+                               (loop2 100 (loop 100 (fl+ v 1.0)))))))
+
+  (check-loop-allocation (lambda (v)
+                           ;; check that nested loops can work
+                           (letrec* ([loop2 (lambda (n v)
+                                              (if (fx= n 0)
+                                                  (loop 100 (fl+ v 1.0))
+                                                  (loop2 (fx- n 1) v)))]
+                                     [loop (lambda (n v)
+                                             (if (fx= n 0)
+                                                 (fl+ v)
+                                                 (loop (fx- n 1) (fl+ v 1.0))))])
+                             (loop2 100 v))))
+
   (let ([bv (make-bytevector 8 0)])
     (check-loop-allocation (lambda (v) (fl+ v (bytevector-ieee-double-native-ref bv 0)))))
   (let ([bv (make-bytevector 8 0)])

release_notes/release_notes.stex

@@ -149,6 +149,14 @@ Improve unboxing of floating-point arguments to
 \scheme{fl-make-rectangular}. Adjust x86\_64 instruction selection
 to reduce false dependencies for floating-point operations.
 
+\subsection{Compiler loop-detection improvements (10.5.0)}
+
+The compiler now detects loop patterns more consistently, turning any
+function that only tail-calls itself and has a single external call
+site into a loop form. That transformation can, in turn, aid
+floating-point unboxing (in the sense of
+Section~\ref{sec:unbox-floats}).
+
 \subsection{Named Cost Center (10.4.0)}
 
 The procedure \scheme{make-cost-center} now

s/cpletrec.ss

@@ -253,7 +253,9 @@ Handling letrec and letrec*
                   ; dropping source here; could attach to body or add source record
                   body
                   (nanopass-case (Lsrc Expr) body
-                    ; assimilate nested letrecs
+                    ;; used to assimilate nested letrecs, but why?
+                    ;; keeping them ordered and split via SCC improves loop conversion
+                    #;
                     [(letrec ([,x* ,e*] ...) ,body)
                      `(letrec ([,(append lhs* x*) ,(append rhs* e*)] ...) ,body)]
                     [else `(letrec ([,lhs* ,rhs*] ...) ,body)]))))

s/cpnanopass.ss

@@ -1073,75 +1073,138 @@
                 ;; no extra wrapper needed
                 e))]))
 
-    (define-pass np-recognize-loops : L4.75 (ir) -> L4.875 ()
-      ; TODO: also recognize andmap/for-all, ormap/exists, for-each
-      ;       and remove inline handlers
+    (define-pass np-recognize-loops : L4.75 (ir) -> L4.75 ()
+      ;; Sets the `loop` flag on uvars, where a loop uvar is bound to
+      ;; a function that calls itself only in tail position, and there's
+      ;; one other call from outside, all with the right number of arguments.
+      ;; Rely on `cpletrec` to break up `letrec`s into SCCs, so a loop
+      ;; candidate will be by itself in its own `letrec`.
+      (Expr : Expr (ir tail*) -> * ()
+        [,x (uvar-loop! x #f)]
+        [(letrec ([,x1 (case-lambda ,info1
+                         (clause (,x* ...) ,interface
+                           ,body))])
+           ,e)
+         (uvar-loop! x1 #t)
+         (uvar-maybe-loop-entry! x1 #t)
+         (uvar-applied-once! x1 #f)
+         (Expr e tail*)
+         (uvar-maybe-loop-entry! x1 #f)
+         (Expr body (list x1))]
+        [(letrec ([,x* ,[Expr : le* '() -> le*]] ...) ,[Expr : body tail* -> body]) (void)]
+        [(call ,info ,mdcl ,x1 ,[Expr : e* '() -> e*] ...)
+         (cond
+           [(uvar-maybe-loop-entry? x1)
+            (cond
+              [(or (uvar-applied-once? x1)
+                   (not (let ([interface* (info-lambda-interface* (uvar-info-lambda x1))])
+                          (and (fx= (length interface*) 1) (fx= (length e*) (car interface*))))))
+               (uvar-applied-once! x1 #f)
+               (uvar-loop! x1 #f)]
+              [else
+               (uvar-applied-once! x1 #t)])]
+           [(uvar-loop? x1)
+            (cond
+              [(memq x1 tail*)
+               (let ([interface* (info-lambda-interface* (uvar-info-lambda x1))])
+                 (unless (and (fx= (length interface*) 1) (fx= (length e*) (car interface*)))
+                   (uvar-loop! x1 #f)))]
+              [else
+               (uvar-loop! x1 #f)])])]
+        [(call ,info ,mdcl ,[Expr : e '() -> e] ,[Expr : e* '() -> e*] ...) (void)]
+        [(foreign-call ,info ,[Expr : e '() -> e] ,[Expr : e* '() -> e*] ...) (void)]
+        [(fcallable ,info) (void)]
+        [(label ,l ,[Expr : body tail* -> body]) (void)]
+        [(mvlet ,[Expr : e '() -> e] ((,x** ...) ,interface* ,[Expr : body* tail* -> body*]) ...) (void)]
+        [(mvcall ,info ,[Expr : e1 '() -> e1] ,[Expr : e2 '() -> e2]) (void)]
+        [(let ([,x ,[Expr : e* '() -> e*]] ...) ,[Expr : body tail* -> body]) (void)]
+        [(case-lambda ,info ,[CaseLambdaClause : cl] ...) (void)]
+        [(quote ,d) (void)]
+        [(if ,[Expr : e0 '() -> e0] ,[Expr : e1 tail* -> e1] ,[Expr : e2 tail* -> e2]) (void)]
+        [(seq ,[Expr : e0 '() -> e0] ,[Expr : e1 tail* -> e1]) (void)]
+        [(profile ,src) (void)]
+        [(pariah) (void)]
+        [,pr (void)]
+        [else ($oops who "unexpected Expr ~s" ir)])
+      (CaseLambdaClause : CaseLambdaClause (cl) -> * ()
+        [(clause (,x* ...) ,interface ,[Expr : body '() -> body]) (void)])
+      (CaseLambdaExpr : CaseLambdaExpr (ir) -> * ()
+        [(case-lambda ,info ,[CaseLambdaClause : cl] ...) (void)])
+      (begin (CaseLambdaExpr ir) ir))
+
+    (define-pass np-convert-loops : L4.75 (ir) -> L4.875 ()
+      ;; Moves each loop function to its unique call site and converts
+      ;; to the `loop` function.
+      ;; TODO: also recognize andmap/for-all, ormap/exists, for-each
+      ;;       and remove inline handlers
       (definitions
         (define make-assigned-tmp
           (lambda (x)
             (let ([t (make-tmp 'tloop)])
               (uvar-assigned! t #t)
               t))))
-      (Expr : Expr (ir [tail* '()]) -> Expr ()
-        [,x (uvar-referenced! x #t) (uvar-loop! x #f) x]
+      (Expr : Expr (ir to-enter) -> Expr ()
+        [,x x]
         [(letrec ([,x1 (case-lambda ,info1
                          (clause (,x* ...) ,interface
-                           ,body))])
-           (call ,info2 ,mdcl ,x2 ,e* ...))
-         (guard (eq? x2 x1) (eq? (length e*) interface))
+                                 ,body))])
+           ,e)
+         (guard (uvar-loop? x1))
          (uvar-referenced! x1 #f)
-         (uvar-loop! x1 #t)
-         (let ([tref?* (map uvar-referenced? tail*)])
-           (for-each (lambda (x) (uvar-referenced! x #f)) tail*)
-           (let ([e* (map (lambda (e) (Expr e '())) e*)]
-                 [body (Expr body (cons x1 tail*))])
-             (let ([body-tref?* (map uvar-referenced? tail*)])
-               (for-each (lambda (x tref?) (when tref? (uvar-referenced! x #t))) tail* tref?*)
-               (if (uvar-referenced? x1)
-                   (if (uvar-loop? x1)
-                       (let ([t* (map make-assigned-tmp x*)])
-                         `(let ([,t* ,e*] ...)
-                            (loop ,x1 (,t* ...)
-                              (let ([,x* ,t*] ...)
-                                ,body))))
-                       (begin
-                         (for-each (lambda (x body-tref?)
-                                     (when body-tref? (uvar-loop! x #f)))
-                           tail* body-tref?*)
-                         `(letrec ([,x1 (case-lambda ,info1
-                                          (clause (,x* ...) ,interface
-                                            ,body))])
-                            (call ,info2 ,mdcl ,x2 ,e* ...))))
-                   `(let ([,x* ,e*] ...) ,body)))))]
+         (let ([body (Expr body to-enter)])
+           (let ([used? (uvar-referenced? x1)])
+             (Expr e (cons (cons x1 (lambda (info2 mdcl e*)
+                                      (cond
+                                        [used?
+                                         (let ([t* (map make-assigned-tmp x*)])
+                                           `(let ([,t* ,e*] ...)
+                                              (loop ,x1 (,t* ...)
+                                                    (let ([,x* ,t*] ...)
+                                                      ,body))))]
+                                        [else
+                                         (uvar-referenced! x1 #f)
+                                         `(let ([,x* ,e*] ...)
+                                            ,body)])))
+                           to-enter))))]
         [(letrec ([,x* ,[le*]] ...) ,[body])
          `(letrec ([,x* ,le*] ...) ,body)]
-        [(call ,info ,mdcl ,x ,[e* '() -> e*] ...)
-         (guard (memq x tail*))
-         (uvar-referenced! x #t)
-         (let ([interface* (info-lambda-interface* (uvar-info-lambda x))])
-           (unless (and (fx= (length interface*) 1) (fx= (length e*) (car interface*)))
-             (uvar-loop! x #f)))
-         `(call ,info ,mdcl ,x ,e* ...)]
-        [(call ,info ,mdcl ,[e '() -> e] ,[e* '() -> e*] ...)
+        [(call ,info ,mdcl ,x ,e* ...)
+         (let ([e* (map (lambda (e) (Expr e to-enter)) e*)]
+               [p (assq x to-enter)])
+           (cond
+             [p ((cdr p) info mdcl e*)]
+             [else
+              (uvar-referenced! x #t)
+              (let ([x (Expr x to-enter)])
+                `(call ,info ,mdcl ,x ,e* ...))]))]
+        [(call ,info ,mdcl ,[e] ,[e*] ...)
          `(call ,info ,mdcl ,e ,e* ...)]
-        [(foreign-call ,info ,[e '() -> e] ,[e* '() -> e*] ...)
+        [(foreign-call ,info ,[e] ,[e*] ...)
          `(foreign-call ,info ,e ,e* ...)]
         [(fcallable ,info) `(fcallable ,info)]
         [(label ,l ,[body]) `(label ,l ,body)]
-        [(mvlet ,[e '() -> e] ((,x** ...) ,interface* ,[body*]) ...)
+        [(mvlet ,[e] ((,x** ...) ,interface* ,[body*]) ...)
          `(mvlet ,e ((,x** ...) ,interface* ,body*) ...)]
-        [(mvcall ,info ,[e1 '() -> e1] ,[e2 '() -> e2])
+        [(mvcall ,info ,[e1] ,[e2])
          `(mvcall ,info ,e1 ,e2)]
-        [(let ([,x ,[e* '() -> e*]] ...) ,[body])
+        [(let ([,x ,[e*]] ...) ,[body])
          `(let ([,x ,e*] ...) ,body)]
-        [(case-lambda ,info ,[cl] ...) `(case-lambda ,info ,cl ...)]
+        [(case-lambda ,info ,[CaseLambdaClause : cl to-enter -> cl] ...) `(case-lambda ,info ,cl ...)]
         [(quote ,d) `(quote ,d)]
-        [(if ,[e0 '() -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
-        [(seq ,[e0 '() -> e0] ,[e1]) `(seq ,e0 ,e1)]
+        [(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
+        [(seq ,[e0] ,[e1])
+         `(seq ,e0 ,e1)]
         [(profile ,src) `(profile ,src)]
         [(pariah) `(pariah)]
         [,pr pr]
-        [else ($oops who "unexpected Expr ~s" ir)]))
+        [else ($oops who "unexpected Expr ~s" ir)])
+      (CaseLambdaClause : CaseLambdaClause (cl to-enter) -> CaseLambdaClause ()
+        [(clause (,x* ...) ,interface ,[Expr : body to-enter -> body])
+         `(clause (,x* ...) ,interface ,body)])
+      (CaseLambdaExpr : CaseLambdaExpr (ir to-enter) -> CaseLambdaExpr ()
+        [(case-lambda ,info ,[CaseLambdaClause : cl* to-enter -> cl*] ...)
+         `(case-lambda ,info ,cl* ...)])
+      (CaseLambdaExpr ir '()))
 
     (define-pass np-recognize-attachment : L4.875 (ir) -> L4.9375 ()
       (definitions
@@ -2399,7 +2462,7 @@
                                           (closure-seen! loc #t)
                                           (fx (cdr x*) free* (cons (closure-name loc) sibling*))
                                           (closure-seen! loc #f)))]
-                                   [else (sorry! who "unexpected uvar location ~s" loc)])))))))
+                                   [else (sorry! who "unexpected uvar location ~s ~s" loc x)])))))))
                  c*)
 
                ; find closures w/free variables (non-constant closures) and propagate
@@ -10854,7 +10917,8 @@
               (pass np-suppress-procedure-checks unparse-L4)
               (pass np-recognize-mrvs unparse-L4.5)
               (pass np-expand-foreign unparse-L4.75)
-              (pass np-recognize-loops unparse-L4.875)
+              (pass np-recognize-loops unparse-L4.75)
+              (pass np-convert-loops unparse-L4.875)
               (pass np-recognize-attachment unparse-L4.9375)
               (pass np-name-anonymous-lambda unparse-L5)
               (pass np-convert-closures unparse-L6)

s/np-languages.ss

@@ -22,6 +22,7 @@
     uvar-was-closure-ref? uvar-was-closure-ref!
     uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save!
     uvar-seen? uvar-seen! uvar-loop? uvar-loop! uvar-poison? uvar-poison!
+    uvar-maybe-loop-entry? uvar-maybe-loop-entry! uvar-applied-once? uvar-applied-once!
     uvar-in-prefix? uvar-in-prefix!
     uvar-location uvar-location-set!
     uvar-move* uvar-move*-set!
@@ -237,16 +238,18 @@
                  ...)))))))
 
   (define-flag-field uvar flags
-    (referenced         #b00000000001)
-    (assigned           #b00000000010)
-    (unspillable        #b00000000100)
-    (spilled            #b00000001000)
-    (seen               #b00000010000)
-    (was-closure-ref    #b00000100000)
-    (loop               #b00001000000)
-    (in-prefix          #b00010000000)
-    (local-save         #b00100000000)
-    (poison             #b01000000000)
+    (referenced         #b0000000000001)
+    (assigned           #b0000000000010)
+    (unspillable        #b0000000000100)
+    (spilled            #b0000000001000)
+    (seen               #b0000000010000)
+    (was-closure-ref    #b0000000100000)
+    (loop               #b0000001000000)
+    (in-prefix          #b0000010000000)
+    (local-save         #b0000100000000)
+    (poison             #b0001000000000)
+    (maybe-loop-entry   #b0010000000000) ; during loop detection
+    (applied-once       #b0100000000000) ; during loop detection
   )
 
   (define-record-type (uvar $make-uvar uvar?)