[Guile-commits] 12/19: Closure conversion produces high-level object representations

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit e4f9b203f7fc3f34481e40ddaf7e12089eaff8c0
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 22 09:17:08 2023 +0200

    Closure conversion produces high-level object representations
    
    * module/language/cps/closure-conversion.scm (convert-one): Build
    closures with make-closure, cons, and so on; leave lowering to scm-ref
    to the backend.
---
 module/language/cps/closure-conversion.scm | 115 +++++++++++++----------------
 1 file changed, 52 insertions(+), 63 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index 875552b87..7152ca589 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2021 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -34,11 +34,7 @@
 
 (define-module (language cps closure-conversion)
   #:use-module (ice-9 match)
-  #:use-module ((srfi srfi-1) #:select (fold
-                                        filter-map
-                                        ))
-  #:use-module (srfi srfi-11)
-  #:use-module (system base types internal)
+  #:use-module ((srfi srfi-1) #:select (fold filter-map))
   #:use-module (language cps)
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
@@ -521,17 +517,22 @@ Otherwise @var{var} is bound, so @var{k} is called with 
@var{var}."
             (with-cps cps
               ($ (k self)))
             (let* ((idx (intset-find free var))
-                   (param (cond
-                           ((not self-known?) (cons 'closure (+ idx 2)))
-                           ((= nfree 2)       (cons 'pair idx))
-                           (else              (cons 'vector (+ idx 1))))))
+                   (ref (cond
+                         ((not self-known?)
+                          (build-exp
+                            ($primcall 'closure-ref idx (self))))
+                         ((= nfree 2)
+                          (build-exp
+                            ($primcall (match idx (0 'car) (1 'cdr)) #f
+                                       (self))))
+                         (else
+                          (build-exp
+                            ($primcall 'vector-ref/immediate idx (self)))))))
               (with-cps cps
                 (letv var*)
                 (let$ body (k var*))
                 (letk k* ($kargs (#f) (var*) ,body))
-                (build-term
-                  ($continue k* #f
-                    ($primcall 'scm-ref/immediate param (self))))))))
+                (build-term ($continue k* #f ,ref))))))
        (else
         (with-cps cps
           ($ (k var))))))
@@ -563,28 +564,13 @@ term."
         (#(#f nfree)
          ;; The call sites cannot be enumerated; allocate a closure.
          (with-cps cps
-           (letv closure tag code)
-           (letk k* ($kargs () ()
-                      ($continue k src ($values (closure)))))
-           (letk kinit ($kargs ('code) (code)
-                         ($continue k* src
-                           ($primcall 'word-set!/immediate '(closure . 1)
-                                      (closure code)))))
-           (letk kcode ($kargs () ()
-                         ($continue kinit src ($code label))))
-           (letk ktag1
-                 ($kargs ('tag) (tag)
-                   ($continue kcode src
-                     ($primcall 'word-set!/immediate '(closure . 0)
-                                (closure tag)))))
-           (letk ktag0
-                 ($kargs ('closure) (closure)
-                   ($continue ktag1 src
-                     ($primcall 'load-u64 (+ %tc7-program (ash nfree 16)) 
()))))
+           (letv code)
+           (letk kalloc
+                 ($kargs ('code) (code)
+                   ($continue k src
+                     ($primcall 'make-closure nfree (code)))))
            (build-term
-             ($continue ktag0 src
-               ($primcall 'allocate-words/immediate `(closure . ,(+ nfree 2))
-                          ())))))
+             ($continue kalloc src ($code label)))))
         (#(#t 0)
          (with-cps cps
            (build-term ($continue k src ($const #f)))))
@@ -600,33 +586,25 @@ term."
          ;; Well-known closure with two free variables; the closure is a
          ;; pair.
          (with-cps cps
+           (letv false)
+           (letk kalloc
+                 ($kargs ('false) (false)
+                   ($continue k src ($primcall 'cons #f (false false)))))
            (build-term
-             ($continue k src
-               ($primcall 'allocate-words/immediate `(pair . 2) ())))))
+             ($continue kalloc src ($const #f)))))
         ;; Well-known callee with more than two free variables; the closure
         ;; is a vector.
         (#(#t nfree)
          (unless (> nfree 2)
            (error "unexpected well-known nullary, unary, or binary closure"))
          (with-cps cps
-           (letv v w0)
-           (letk k* ($kargs () () ($continue k src ($values (v)))))
-           (letk ktag1
-                 ($kargs ('w0) (w0)
-                   ($continue k* src
-                     ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
-           (letk ktag0
-                 ($kargs ('v) (v)
-                   ($continue ktag1 src
-                     ($primcall 'load-u64 (+ %tc7-vector (ash nfree 8)) ()))))
            (build-term
-             ($continue ktag0 src
-               ($primcall 'allocate-words/immediate `(vector . ,(1+ nfree))
-                          ())))))))
+             ($continue k src
+               ($primcall 'allocate-vector/immediate nfree ())))))))
 
-    (define (init-closure cps k src var known? free)
+    (define (init-closure cps k src closure known? free)
       "Initialize the free variables @var{closure-free} in a closure
-bound to @var{var}, and continue to @var{k}."
+bound to @var{closure}, and continue to @var{k}."
       (let ((count (intset-count free)))
         (cond
          ((and known? (<= count 1))
@@ -635,15 +613,28 @@ bound to @var{var}, and continue to @var{k}."
           (with-cps cps
             (build-term ($continue k src ($values ())))))
          (else
-          ;; Otherwise residualize a sequence of scm-set!.
-          (let-values (((kind offset)
-                        ;; What are we initializing?  A closure if the
-                        ;; procedure is not well-known; a pair if it has
-                        ;; only 2 free variables; otherwise, a vector.
-                        (cond
-                         ((not known?) (values 'closure 2))
-                         ((= count 2)  (values 'pair 0))
-                         (else         (values 'vector 1)))))
+          ;; Otherwise residualize initializations.
+          (let ((make-init-exp
+                 ;; What are we initializing?  A closure if the
+                 ;; procedure is not well-known; a pair if it has
+                 ;; only 2 free variables; otherwise, a vector.
+                 (cond
+                  ((not known?)
+                   (lambda (idx val)
+                     (build-exp
+                       ($primcall 'closure-set! idx (closure val)))))
+                  ((= count 2)
+                   (lambda (idx val)
+                     (match idx
+                       (0 (build-exp
+                            ($primcall 'set-car! #f (closure val))))
+                       (1 (build-exp
+                            ($primcall 'set-cdr! #f (closure val)))))))
+                  (else
+                   (lambda (idx val)
+                     (build-exp
+                       ($primcall 'vector-set!/immediate idx
+                                  (closure val))))))))
             (let lp ((cps cps) (prev #f) (idx 0))
               (match (intset-next free prev)
                 (#f (with-cps cps
@@ -656,9 +647,7 @@ bound to @var{var}, and continue to @var{k}."
                             (with-cps cps
                               (build-term
                                 ($continue k src
-                                  ($primcall 'scm-set!/immediate
-                                             (cons kind (+ offset idx))
-                                             (var v)))))))))))))))))
+                                  ,(make-init-exp idx v))))))))))))))))
 
     (define (make-single-closure cps k src kfun)
       (let ((free (intmap-ref free-vars kfun)))