From 1b0638c1c9c6b6e25ec816f9e1fab3ecc371e815 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 23 Sep 2026 15:08:07 -0600 Subject: [PATCH] improve loop detection Generalize the recognized pattern from ``` (letrec ([f (lambda ....)]) (f arg ...)) ``` to allow a loop entry into `f` to be anywhere in the `letrec` body as long as there's a single call to `f` as an entry point (and `f` is otherwise only tail-called within the `lambda` body). Also, avoid merging `letrec`s in the cpletrec pass, which can otherwise obscure loops. --- mats/fl.ms | 49 ++++++++++ release_notes/release_notes.stex | 8 ++ s/cpletrec.ss | 4 +- s/cpnanopass.ss | 162 +++++++++++++++++++++---------- s/np-languages.ss | 23 +++-- 5 files changed, 186 insertions(+), 60 deletions(-) diff --git a/mats/fl.ms b/mats/fl.ms index c6189d546..fc021344b 100644 --- a/mats/fl.ms +++ b/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)]) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index a3c4f18ee..20821b97b 100644 --- a/release_notes/release_notes.stex +++ b/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 diff --git a/s/cpletrec.ss b/s/cpletrec.ss index d2aad9cdc..44f07ae0e 100644 --- a/s/cpletrec.ss +++ b/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)])))) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 7c7851bde..325806abd 100644 --- a/s/cpnanopass.ss +++ b/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) diff --git a/s/np-languages.ss b/s/np-languages.ss index 688a0ec18..71cdc9437 100644 --- a/s/np-languages.ss +++ b/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?)