wingo pushed a commit to branch main in repository guile. commit e4f9b203f7fc3f34481e40ddaf7e12089eaff8c0 Author: Andy Wingo <wi...@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)))