summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorChristine Lemmer-Webber <cwebber@dustycloud.org>2021-10-10 20:59:04 -0400
committerChristine Lemmer-Webber <cwebber@dustycloud.org>2021-10-10 20:59:04 -0400
commit204cb986469b2751a3c3347a34a8013c1a0b6954 (patch)
treee91534db67add400e5213ec3becb6ab48544b470 /module
parentb03b359b5b16c040c485a565f3ce92481ea43f41 (diff)
parente60469c8b6936575c079faaffa40a340e1d49f3c (diff)
downloadguile-204cb986469b2751a3c3347a34a8013c1a0b6954.tar.gz
Merge branch 'main' into compile-to-js-merge
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am3
-rw-r--r--module/ice-9/boot-9.scm16
-rw-r--r--module/ice-9/ftw.scm8
-rw-r--r--module/ice-9/match.upstream.scm69
-rw-r--r--module/ice-9/psyntax.scm1
-rw-r--r--module/ice-9/read.scm7
-rw-r--r--module/language/cps/cse.scm8
-rw-r--r--module/language/cps/dump.scm317
-rw-r--r--module/language/cps/effects-analysis.scm81
-rw-r--r--module/language/cps/graphs.scm88
-rw-r--r--module/language/cps/slot-allocation.scm214
-rw-r--r--module/language/cps/types.scm2
-rw-r--r--module/language/cps/utils.scm174
-rw-r--r--module/language/tree-il/compile-bytecode.scm6
-rw-r--r--module/language/tree-il/compile-cps.scm11
-rw-r--r--module/language/tree-il/inlinable-exports.scm869
-rw-r--r--module/language/tree-il/letrectify.scm20
-rw-r--r--module/language/tree-il/optimize.scm11
-rw-r--r--module/language/tree-il/peval.scm192
-rw-r--r--module/language/tree-il/primitives.scm3
-rw-r--r--module/language/tree-il/resolve-free-vars.scm282
-rw-r--r--module/scheme/base.scm49
-rw-r--r--module/srfi/srfi-1.scm4
-rw-r--r--module/srfi/srfi-43.scm43
-rw-r--r--module/system/base/optimize.scm7
-rw-r--r--module/system/foreign-library.scm2
-rw-r--r--module/system/repl/command.scm17
-rw-r--r--module/system/repl/common.scm26
-rw-r--r--module/system/vm/assembler.scm7
-rw-r--r--module/system/vm/trace.scm2
30 files changed, 2089 insertions, 450 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index b440946f2..d340005da 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -53,6 +53,7 @@ SOURCES = \
language/cps/cse.scm \
language/cps/dce.scm \
language/cps/devirtualize-integers.scm \
+ language/cps/dump.scm \
language/cps/elide-arity-checks.scm \
language/cps/effects-analysis.scm \
language/cps/graphs.scm \
@@ -90,10 +91,12 @@ SOURCES = \
language/tree-il/effects.scm \
language/tree-il/eta-expand.scm \
language/tree-il/fix-letrec.scm \
+ language/tree-il/inlinable-exports.scm \
language/tree-il/letrectify.scm \
language/tree-il/optimize.scm \
language/tree-il/peval.scm \
language/tree-il/primitives.scm \
+ language/tree-il/resolve-free-vars.scm \
language/tree-il/spec.scm \
\
ice-9/and-let-star.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 944061707..2323b1ec5 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2513,7 +2513,8 @@ name extensions listed in %load-extensions."
public-interface
filename
next-unique-id
- (replacements #:no-setter))))
+ (replacements #:no-setter)
+ inlinable-exports)))
;; make-module &opt size uses binder
@@ -2539,7 +2540,7 @@ initial uses list, or binding procedure."
'()
(make-weak-key-hash-table) #f
(make-hash-table) #f #f #f 0
- (make-hash-table)))
+ (make-hash-table) #f))
@@ -3380,7 +3381,8 @@ error if selected binding does not exist in the used module."
(define* (define-module* name
#:key filename pure version (imports '()) (exports '())
(replacements '()) (re-exports '()) (re-export-replacements '())
- (autoloads '()) (duplicates #f) transformer declarative?)
+ (autoloads '()) (duplicates #f) transformer declarative?
+ inlinable-exports)
(define (list-of pred l)
(or (null? l)
(and (pair? l) (pred (car l)) (list-of pred (cdr l)))))
@@ -3446,6 +3448,12 @@ error if selected binding does not exist in the used module."
(sym (car (last-pair transformer))))
(set-module-transformer! module (module-ref iface sym))))
+ (when inlinable-exports
+ (unless (procedure? inlinable-exports)
+ (error "expected inlinable-exports to be a procedure" inlinable-exports))
+ (set-module-inlinable-exports! (module-public-interface module)
+ inlinable-exports))
+
(run-hook module-defined-hook module)
module))
@@ -3481,7 +3489,7 @@ error if selected binding does not exist in the used module."
#:warning "Failed to autoload ~a in ~a:\n" sym name))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
(make-hash-table 0) '() (make-weak-value-hash-table) #f
- (make-hash-table 0) #f #f #f 0 (make-hash-table 0))))
+ (make-hash-table 0) #f #f #f 0 (make-hash-table 0) #f)))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index dd6f49089..ac6aa6316 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -307,10 +307,10 @@
(else (values s (easy-flag s))))))))
(define (clean name)
- (let ((last-char-index (1- (string-length name))))
- (if (char=? #\/ (string-ref name last-char-index))
- (substring name 0 last-char-index)
- name)))
+ (let ((end (- (string-length name) 1)))
+ (if (and (positive? end) (char=? #\/ (string-ref name end)))
+ (substring name 0 end)
+ name)))
(define (ftw filename proc . options)
(let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index b1fc371b8..ff5e535db 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -210,6 +210,12 @@
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
+;; 2021/06/21 - fix for `(a ...)' patterns where `a' is already bound
+;; (thanks to Andy Wingo)
+;; 2020/09/04 - [OMITTED IN GUILE] perf fix for `not`; rename `..=', `..=', `..1' per SRFI 204
+;; 2020/08/21 - [OMITTED IN GUILE] fixing match-letrec with unhygienic insertion
+;; 2020/07/06 - [OMITTED IN GUILE] adding `..=' and `..=' patterns; fixing ,@ patterns
+;; 2016/10/05 - [OMITTED IN GUILE] treat keywords as literals, not identifiers, in Chicken
;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns
;; 2014/11/24 - [OMITTED IN GUILE] adding Gauche's `@' pattern for named record field matching
@@ -509,9 +515,9 @@
((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p
;; simplest case equivalent to (p ...), just bind the list
- (let ((p v))
- (if (list? p)
- (sk ... i)
+ (let ((w v))
+ (if (list? w)
+ (match-one w p g+s (sk ...) fk i)
fk))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
@@ -525,30 +531,47 @@
fk i)))
(else
fk)))))
- ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
- ;; general case, trailing patterns to match, keep track of the
- ;; remaining list length so we don't need any backtracking
+ ((_ v p r g+s sk fk (i ...) ((id id-ls) ...))
(match-verify-no-ellipsis
r
- (let* ((tail-len (length 'r))
- (ls v)
- (len (and (list? ls) (length ls))))
- (if (or (not len) (< len tail-len))
- fk
- (let loop ((ls ls) (n len) (id-ls '()) ...)
- (cond
+ (match-bound-identifier-memv
+ p
+ (i ...)
+ ;; p is bound, match the list up to the known length, then
+ ;; match the trailing patterns
+ (let loop ((ls v) (expect p))
+ (cond
+ ((null? expect)
+ (match-one ls r (#f #f) sk fk (i ...)))
+ ((pair? ls)
+ (let ((w (car ls))
+ (e (car expect)))
+ (if (equal? (car ls) (car expect))
+ (match-drop-ids (loop (cdr ls) (cdr expect)))
+ fk)))
+ (else
+ fk)))
+ ;; general case, trailing patterns to match, keep track of the
+ ;; remaining list length so we don't need any backtracking
+ (let* ((tail-len (length 'r))
+ (ls v)
+ (len (and (list? ls) (length ls))))
+ (if (or (not len) (< len tail-len))
+ fk
+ (let loop ((ls ls) (n len) (id-ls '()) ...)
+ (cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
- (match-one ls r (#f #f) (sk ...) fk i)))
+ (match-one ls r (#f #f) sk fk (i ... id ...))))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
- i)))
+ (i ...))))
(else
- fk)))))))))
+ fk))))))))))
;; This is just a safety check. Although unlike syntax-rules we allow
;; trailing patterns after an ellipsis, we explicitly disable multiple
@@ -915,3 +938,17 @@
;; otherwise x is a non-symbol datum
((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k)))))
+
+(define-syntax match-bound-identifier-memv
+ (syntax-rules ()
+ ((match-bound-identifier-memv a (id ...) sk fk)
+ (match-check-identifier
+ a
+ (let-syntax
+ ((memv?
+ (syntax-rules (id ...)
+ ((memv? a sk2 fk2) fk2)
+ ((memv? anything-else sk2 fk2) sk2))))
+ (memv? random-sym-to-match sk fk))
+ fk))))
+
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 663d9275a..bd4bd6723 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2157,6 +2157,7 @@
(lambda ()
(gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps))))
+ (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
(() (values '(quote ()) maps))
(_ (values `(quote ,e) maps))))))
diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm
index ac407739f..283933064 100644
--- a/module/ice-9/read.scm
+++ b/module/ice-9/read.scm
@@ -556,12 +556,15 @@
(string->symbol
(list->string
(let lp ((saw-brace? #f))
- (let ((ch (next-not-eof)))
+ (let lp/inner ((ch (next-not-eof))
+ (saw-brace? saw-brace?))
(cond
(saw-brace?
(if (eqv? ch #\#)
'()
- (cons #\} (lp #f))))
+ ;; Don't eat CH, see
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=49623>.
+ (cons #\} (lp/inner ch #f))))
((eqv? ch #\})
(lp #t))
((eqv? ch #\\)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 55cf5490e..3c67a043a 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -360,9 +360,9 @@ for a label, it isn't known to be constant at that label."
(_ bool))
(match (and (< pred succ) (intmap-ref out pred))
(($ $kargs _ _ ($ $branch kf kt src 'eq-constant? c (v)))
- (if (eqv? kt succ)
- (adjoin-constant consts v c)
- consts))
+ (if (eqv? kf succ)
+ consts
+ (adjoin-constant consts v c)))
(_ consts)))))))
(define (propagate-analysis analysis label out)
@@ -735,7 +735,7 @@ for a label, it isn't known to be constant at that label."
;; post-order, so the intmap-fold will visit definitions before
;; uses.
(let* ((effects (synthesize-definition-effects (compute-effects conts)))
- (clobbers (compute-clobber-map effects))
+ (clobbers (compute-clobber-map conts effects))
(succs (compute-successors conts kfun))
(preds (invert-graph succs))
(avail (compute-available-expressions succs kfun clobbers))
diff --git a/module/language/cps/dump.scm b/module/language/cps/dump.scm
new file mode 100644
index 000000000..d5217fe23
--- /dev/null
+++ b/module/language/cps/dump.scm
@@ -0,0 +1,317 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; Helper facilities for working with CPS.
+;;;
+;;; Code:
+
+(define-module (language cps dump)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps intset)
+ #:use-module (language cps intmap)
+ #:use-module (language cps graphs)
+ #:use-module (language cps utils)
+ #:export (dump))
+
+;; ideas: unused vars print as _
+;; print all labels
+;; call bb headers with values
+;; annotate blocks with available bindings? live bindings?
+;; how to print calls...
+;; dot graph
+
+(define (cont-successors cont)
+ (match cont
+ (($ $kargs _ _ term)
+ (match term
+ (($ $continue k) (list k))
+ (($ $branch kf kt) (list kf kt))
+ (($ $switch kf kt*) (cons kf kt*))
+ (($ $prompt k kh) (list k kh))
+ (($ $throw) '())))
+ (($ $kclause _ kbody kalternate)
+ (if kalternate
+ (list kbody kalternate)
+ (list kbody)))
+ (($ $kfun src meta self ktail kentry)
+ (list ktail kentry))
+ (($ $kreceive arity kargs) (list kargs))
+ (($ $ktail) '())))
+
+(define (compute-block-entries cps kfun body all-labels?)
+ (if all-labels?
+ body
+ (let ((preds (compute-predecessors cps kfun #:labels body)))
+ ;; Conts whose predecessor count is not 1 start blocks.
+ (define (add-entry label blocks)
+ (match (intmap-ref preds label)
+ ((_) blocks)
+ (_ (intset-add! blocks label))))
+ ;; Continuations of branches start blocks.
+ (define (add-exits label blocks)
+ (fold1 (lambda (succ blocks)
+ (intset-add! blocks succ))
+ (match (cont-successors (intmap-ref cps label))
+ ((_) '())
+ (succs succs))
+ blocks))
+ (persistent-intset
+ (intset-fold
+ (lambda (label blocks)
+ (add-exits label (add-entry label blocks)))
+ body
+ empty-intset)))))
+
+(define (collect-blocks cps entries)
+ (define (collect-block entry)
+ (let ((cont (intmap-ref cps entry)))
+ (acons entry cont
+ (match (cont-successors (intmap-ref cps entry))
+ ((succ)
+ (if (intset-ref entries succ)
+ '()
+ (collect-block succ)))
+ (_ '())))))
+ (persistent-intmap
+ (intset-fold
+ (lambda (start blocks)
+ (intmap-add! blocks start (collect-block start)))
+ entries
+ empty-intmap)))
+
+(define (compute-block-succs blocks)
+ (intmap-map (lambda (entry conts)
+ (match conts
+ (((_ . _) ... (exit . cont))
+ (fold1 (lambda (succ succs)
+ (intset-add succs succ))
+ (cont-successors cont)
+ empty-intset))))
+ blocks))
+
+(define (dump-block cps port labelled-conts)
+ (define (format-label label) (format #f "L~a" label))
+ (define (format-name name) (if name (symbol->string name) "_"))
+ (define (format-var var) (format #f "v~a" var))
+ (define (format-loc src)
+ (and src
+ (format #f "~a:~a:~a"
+ (or (assq-ref src 'filename) "<unknown>")
+ (1+ (assq-ref src 'line))
+ (assq-ref src 'column))))
+ (define (arg-list strs) (string-join strs ", "))
+ (define (false-if-empty str) (if (string-null? str) #f str))
+ (define (format-arity arity)
+ (match arity
+ (($ $arity req opt rest kw aok?)
+ (arg-list
+ `(,@(map format-name req)
+ ,@(map (lambda (name)
+ (format #f "[~a]" (format-name name)))
+ opt)
+ ,@(map (match-lambda
+ ((kw name var)
+ (format #f "~a" kw)))
+ kw)
+ ,@(if aok? '("[#:allow-other-keys]") '())
+ ,@(if rest
+ (list (string-append (format-name rest) "..."))
+ '()))))))
+ (define (format-primcall op param args)
+ (format #f "~a~@[[~s]~](~a)" op param (arg-list (map format-var args))))
+ (define (format-exp exp)
+ (match exp
+ (($ $const val)
+ (format #f "const ~s" val))
+ (($ $prim name)
+ (format #f "prim ~s" name))
+ (($ $fun body)
+ (format #f "fun ~a" (format-label body)))
+ (($ $rec names syms funs)
+ (format #f "rec(~a)" (arg-list (map format-exp funs))))
+ (($ $const-fun label)
+ (format #f "const-fun ~a" (format-label label)))
+ (($ $code label)
+ (format #f "code ~a" (format-label label)))
+ (($ $call proc args)
+ (format #f "call ~a(~a)"
+ (format-var proc) (arg-list (map format-var args))))
+ (($ $callk k proc args)
+ (format #f "callk ~a(~a)" (format-label k)
+ (arg-list
+ (cons (if proc (format-var proc) "_")
+ (map format-var args)))))
+ (($ $primcall name param args)
+ (format-primcall name param args))
+ (($ $values args)
+ (arg-list (map format-var args)))))
+ (define (dump-annotation ann src)
+ (when (or ann src)
+ (format port "~45t ; ~@[~a ~]" ann)
+ (when src
+ (let* ((src (format-loc src))
+ (col (- 80 4 (string-length src))))
+ (format port "~vt at ~a" col src))))
+ (newline port))
+ (define (dump-definition src names vars fmt . args)
+ (define (take formatter val)
+ (cond
+ ((not val) #f)
+ ((string? val) (false-if-empty val))
+ ((null? val) #f)
+ (else (arg-list (map formatter val)))))
+ (let ((names (take format-name names))
+ (vars (take format-var vars)))
+ (format port " ~@[~a := ~]~?" vars fmt args)
+ (dump-annotation names src)))
+ (define (dump-statement src ann fmt . args)
+ (format port " ~?" fmt args)
+ (dump-annotation (and ann (false-if-empty ann)) src))
+ (define (dump-block-header label cont)
+ (match cont
+ (($ $kargs names vars)
+ (format port "~a(~a):"
+ (format-label label)
+ (arg-list (map format-var vars)))
+ (dump-annotation (false-if-empty (arg-list (map format-name names)))
+ #f))
+ (($ $ktail)
+ (values))
+ (($ $kfun src meta self ktail kentry)
+ (let ((name (assq-ref meta 'name)))
+ (format port "~a:" (format-label label))
+ (dump-annotation name src)))
+ ((or ($ $kreceive) ($ $kclause))
+ (format port "~a:\n" (format-label label)))))
+ (define (dump-block-body label cont)
+ (match cont
+ (($ $kargs _ _ ($ $continue k src exp))
+ (match (intmap-ref cps k)
+ (($ $kargs names vars)
+ (dump-definition src names vars "~a" (format-exp exp)))
+ (_
+ (dump-definition src #f #f "~a" (format-exp exp)))))
+ (($ $kreceive arity kargs)
+ (match (intmap-ref cps kargs)
+ (($ $kargs names vars)
+ (dump-definition #f names vars
+ "receive(~a)" (format-arity arity)))))
+ (($ $ktail)
+ (values))
+ (($ $kclause arity kbody #f)
+ (match (intmap-ref cps kbody)
+ (($ $kargs names vars)
+ (dump-definition #f names vars
+ "receive(~a)" (format-arity arity)))))))
+ (define (dump-block-exit label cont)
+ (match cont
+ (($ $kargs _ _ term)
+ (match term
+ (($ $continue k src exp)
+ (match (intmap-ref cps k)
+ (($ $ktail)
+ (match exp
+ (($ $values vals)
+ (dump-statement src #f
+ "return ~a" (arg-list (map format-var vals))))
+ (_
+ (dump-statement src #f
+ "tail ~a" (format-exp exp)))))
+ (_
+ (dump-statement src #f
+ "~a(~a)" (format-label k) (format-exp exp)))))
+ (($ $branch kf kt src op param args)
+ (dump-statement src #f
+ "~a ? ~a() : ~a()"
+ (format-primcall op param args)
+ (format-label kt)
+ (format-label kf)))
+ (($ $switch kf kt* src arg)
+ (dump-statement src #f
+ "[~a]~a() or ~a()"
+ (arg-list (map format-label kt*))
+ (format-var arg)
+ (format-label kf)))
+ (($ $prompt k kh src escape? tag)
+ (dump-statement src #f
+ "~a(prompt(kh:~a,~a tag:~a)"
+ (format-label k)
+ (format-label kh)
+ (if escape? ", escape-only" "")
+ (format-var tag)))
+ (($ $throw src op param args)
+ (dump-statement src #f
+ "throw ~a" (format-primcall op param args)))))
+ (($ $kreceive arity kargs)
+ (dump-statement #f #f
+ "~a(receive(~a))"
+ (format-label kargs)
+ (format-arity arity)))
+ (($ $kfun src meta self ktail kentry)
+ (for-each (match-lambda
+ ((k . v)
+ (unless (eq? k 'name)
+ (format port " meta: ~a: ~s\n" k v))))
+ meta)
+ ;; (format port " tail: ~a:\n" (format-label ktail))
+ (when self
+ (format port " ~a := self\n" (format-var self)))
+ (format port " ~a(...)\n" (format-label kentry)))
+ (($ $kclause arity kbody kalt)
+ (dump-statement #f #f
+ "~a(receive(~a))~@[or ~a()~]\n"
+ (format-label kbody)
+ (format-arity arity)
+ (and=> kalt format-label)))
+ (($ $ktail)
+ (values))))
+ (match labelled-conts
+ (((label . cont) . _)
+ (dump-block-header label cont)))
+ (let lp ((labelled-conts labelled-conts))
+ (match labelled-conts
+ (((label . cont))
+ (dump-block-exit label cont))
+ (((label . cont) . labelled-conts)
+ (dump-block-body label cont)
+ (lp labelled-conts)))))
+
+(define (dump-function cps port kfun body all-labels?)
+ (define entries (compute-block-entries cps kfun body all-labels?))
+ (define blocks (collect-blocks cps entries))
+ (define block-succs (compute-block-succs blocks))
+ (define block-order (compute-reverse-post-order block-succs kfun))
+ (for-each (lambda (entry)
+ (dump-block cps port (intmap-ref blocks entry)))
+ block-order)
+ (values))
+
+(define* (dump cps #:key
+ (port (current-output-port))
+ (entry (intmap-next cps))
+ (all-labels? #f))
+ (let ((functions (compute-reachable-functions cps entry)))
+ (intmap-fold (lambda (kfun body)
+ (unless (eqv? kfun entry) (newline port))
+ (dump-function cps port kfun body all-labels?))
+ functions)))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 365c280c1..cdbc50159 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -221,7 +221,7 @@
(logior &all-effect-kinds (&object &unknown-memory-kinds))))
(define-inlinable (causes-effect? x effects)
- (not (zero? (logand x effects))))
+ (logtest x effects))
(define-inlinable (causes-all-effects? x)
(eqv? x &all-effects))
@@ -238,13 +238,78 @@ is or might be a read or a write to the same location as A."
;; A negative field indicates "the whole object".
;; Non-negative fields indicate only part of the object.
(or (< a 0) (< b 0) (= a b))))))
- (and (not (zero? (logand a &write)))
- (not (zero? (logand b (logior &read &write))))
+ (and (logtest a &write)
+ (logtest b (logior &read &write))
(locations-same?)))
-(define (compute-clobber-map effects)
+(define (compute-known-allocations conts effects)
+ "Return a map of ACCESS-LABEL to ALLOC-LABEL, indicating stores to and
+loads from objects created at known allocation sites."
+ ;; VAR -> ALLOC map of defining allocations, where ALLOC is a label or
+ ;; #f. Possibly sparse.
+ (define allocations
+ (intmap-fold
+ (lambda (label fx out)
+ (match (intmap-ref conts label)
+ (($ $kargs _ _ ($ $continue k))
+ (match (intmap-ref conts k)
+ (($ $kargs (_) (var))
+ (intmap-add out var
+ (and (not (causes-all-effects? fx))
+ (logtest fx &allocation)
+ label)
+ (lambda (old new) #f)))
+ (_ out)))
+ (_ out)))
+ effects empty-intmap))
+
+ (persistent-intmap
+ (intmap-fold
+ (lambda (label fx out)
+ (cond
+ ((causes-all-effects? fx) out)
+ ((logtest fx (logior &read &write))
+ (match (intmap-ref conts label)
+ ;; Assume that instructions which cause a known set of effects
+ ;; and which
+ (($ $kargs names vars
+ ($ $continue k src
+ ($ $primcall name param (obj . args))))
+ (match (intmap-ref allocations obj (lambda (_) #f))
+ (#f out)
+ (allocation-label
+ (intmap-add! out label allocation-label))))
+ (_ out)))
+ (else out)))
+ effects empty-intmap)))
+
+(define (compute-clobber-map conts effects)
"For the map LABEL->EFFECTS, compute a map LABEL->LABELS indicating
the LABELS that are clobbered by the effects of LABEL."
+ (define known-allocations (compute-known-allocations conts effects))
+ (define (filter-may-alias write-label clobbered-labels)
+ ;; We may be able to remove some entries from CLOBBERED-LABELS, if
+ ;; we can prove they are not aliased by WRITE-LABEL.
+ (match (intmap-ref known-allocations write-label (lambda (_) #f))
+ (#f
+ ;; We don't know what object WRITE-LABEL refers to; can't refine.
+ clobbered-labels)
+ (clobber-alloc
+ (intset-fold
+ (lambda (clobbered-label clobbered-labels)
+ (match (intmap-ref known-allocations clobbered-label (lambda (_) #f))
+ (#f
+ ;; We don't know what object CLOBBERED-LABEL refers to;
+ ;; can't refine.
+ clobbered-labels)
+ (clobbered-alloc
+ ;; We know that WRITE-LABEL and CLOBBERED-LABEL refer to
+ ;; known allocations. The write will only clobber the read
+ ;; if the two allocations are the same.
+ (if (eqv? clobber-alloc clobbered-alloc)
+ clobbered-labels
+ (intset-remove clobbered-labels clobbered-label)))))
+ clobbered-labels clobbered-labels))))
(let ((clobbered-by-write (make-hash-table)))
(intmap-fold
(lambda (label fx)
@@ -269,9 +334,11 @@ the LABELS that are clobbered by the effects of LABEL."
effects)
(intmap-map (lambda (label fx)
(if (causes-effect? fx &write)
- (hashv-ref clobbered-by-write
- (ash fx (- &effect-kind-bits))
- empty-intset)
+ (filter-may-alias
+ label
+ (hashv-ref clobbered-by-write
+ (ash fx (- &effect-kind-bits))
+ empty-intset))
empty-intset))
effects)))
diff --git a/module/language/cps/graphs.scm b/module/language/cps/graphs.scm
index 8be36c84d..abdca76c9 100644
--- a/module/language/cps/graphs.scm
+++ b/module/language/cps/graphs.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-2021 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
@@ -23,6 +23,7 @@
;;; Code:
(define-module (language cps graphs)
+ #:use-module (ice-9 control)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps intset)
@@ -33,6 +34,7 @@
intmap-map
intmap-keys
invert-bijection invert-partition
+ rename-keys rename-intset rename-graph
intset->intmap
intmap-select
worklist-fold
@@ -43,7 +45,9 @@
compute-reverse-post-order
compute-strongly-connected-components
compute-sorted-strongly-connected-components
- solve-flow-equations))
+ compute-reverse-control-flow-order
+ solve-flow-equations
+ compute-live-variables))
(define-inlinable (fold1 f l s0)
(let lp ((l l) (s0 s0))
@@ -162,6 +166,32 @@ intset of successors, return a graph SUCC->PRED...."
succs
(intmap-map (lambda (label _) empty-intset) succs)))
+(define (rename-keys map old->new)
+ "Return a fresh intmap containing F(K) -> V for K and V in MAP, where
+F is looking up K in the intmap OLD->NEW."
+ (persistent-intmap
+ (intmap-fold (lambda (k v out)
+ (intmap-add! out (intmap-ref old->new k) v))
+ map
+ empty-intmap)))
+
+(define (rename-intset set old->new)
+ "Return a fresh intset of F(K) for K in SET, where F is looking up K
+in the intmap OLD->NEW."
+ (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
+ set empty-intset))
+
+(define (rename-graph graph old->new)
+ "Return a fresh intmap containing F(K) -> intset(F(V)...) for K and
+intset(V...) in GRAPH, where F is looking up K in the intmap OLD->NEW."
+ (persistent-intmap
+ (intmap-fold (lambda (pred succs out)
+ (intmap-add! out
+ (intmap-ref old->new pred)
+ (rename-intset succs old->new)))
+ graph
+ empty-intmap)))
+
(define (compute-strongly-connected-components succs start)
"Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
partitioning the labels into strongly connected components (SCCs)."
@@ -232,6 +262,37 @@ connected components in sorted order."
(((? (lambda (id) (eqv? id start))) . ids)
(map (lambda (id) (intmap-ref components id)) ids))))
+(define (compute-reverse-control-flow-order preds)
+ "Return a LABEL->ORDER bijection where ORDER is a contiguous set of
+integers starting from 0 and incrementing in sort order. There is a
+precondition that labels in PREDS are already renumbered in reverse post
+order."
+ (define (has-back-edge? preds)
+ (let/ec return
+ (intmap-fold (lambda (label labels)
+ (intset-fold (lambda (pred)
+ (if (<= label pred)
+ (return #t)
+ (values)))
+ labels)
+ (values))
+ preds)
+ #f))
+ (if (has-back-edge? preds)
+ ;; This is more involved than forward control flow because not all
+ ;; live labels are reachable from the tail.
+ (persistent-intmap
+ (fold2 (lambda (component order n)
+ (intset-fold (lambda (label order n)
+ (values (intmap-add! order label n)
+ (1+ n)))
+ component order n))
+ (reverse (compute-sorted-strongly-connected-components preds))
+ empty-intmap 0))
+ ;; Just reverse forward control flow.
+ (let ((max (intmap-prev preds)))
+ (intmap-map (lambda (label labels) (- max label)) preds))))
+
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
@@ -274,3 +335,26 @@ SUBTRACT, ADD, and MEET operates on that state."
(run (intset-union worklist changed) in out)))
(values (persistent-intmap in)
(persistent-intmap out)))))))
+
+(define (compute-live-variables preds defs uses)
+ "Compute and return two values mapping LABEL->VAR..., where VAR... are
+the definitions that are live before and after LABEL, as intsets."
+ (let* ((old->new (compute-reverse-control-flow-order preds))
+ (init (persistent-intmap (intmap-fold
+ (lambda (old new init)
+ (intmap-add! init new empty-intset))
+ old->new empty-intmap))))
+ (call-with-values
+ (lambda ()
+ (solve-flow-equations (rename-graph preds old->new)
+ init init
+ (rename-keys defs old->new)
+ (rename-keys uses old->new)
+ intset-subtract intset-union intset-union))
+ (lambda (in out)
+ ;; As a reverse control-flow problem, the values flowing into a
+ ;; node are actually the live values after the node executes.
+ ;; Funny, innit? So we return them in the reverse order.
+ (let ((new->old (invert-bijection old->new)))
+ (values (rename-keys out new->old)
+ (rename-keys in new->old)))))))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index ff32e1ae1..253776769 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -30,6 +30,7 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
+ #:use-module (language cps graphs)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
@@ -121,94 +122,6 @@
(define (lookup-nlocals allocation)
(allocation-frame-size allocation))
-(define-syntax-rule (persistent-intmap2 exp)
- (call-with-values (lambda () exp)
- (lambda (a b)
- (values (persistent-intmap a) (persistent-intmap b)))))
-
-(define (compute-defs-and-uses cps)
- "Return two LABEL->VAR... maps indicating values defined at and used
-by a label, respectively."
- (define (vars->intset vars)
- (fold (lambda (var set) (intset-add set var)) empty-intset vars))
- (persistent-intmap2
- (intmap-fold
- (lambda (label cont defs uses)
- (define (get-defs k)
- (match (intmap-ref cps k)
- (($ $kargs names vars) (vars->intset vars))
- (_ empty-intset)))
- (define (return d u)
- (values (intmap-add! defs label d)
- (intmap-add! uses label u)))
- (match cont
- (($ $kfun src meta self tail clause)
- (return (intset-union
- (if clause (get-defs clause) empty-intset)
- (if self (intset self) empty-intset))
- empty-intset))
- (($ $kargs _ _ ($ $continue k src exp))
- (match exp
- ((or ($ $const) ($ $const-fun) ($ $code))
- (return (get-defs k) empty-intset))
- (($ $call proc args)
- (return (get-defs k) (intset-add (vars->intset args) proc)))
- (($ $callk _ proc args)
- (let ((args (vars->intset args)))
- (return (get-defs k) (if proc (intset-add args proc) args))))
- (($ $primcall name param args)
- (return (get-defs k) (vars->intset args)))
- (($ $values args)
- (return (get-defs k) (vars->intset args)))))
- (($ $kargs _ _ ($ $branch kf kt src op param args))
- (return empty-intset (vars->intset args)))
- (($ $kargs _ _ ($ $switch kf kt* src arg))
- (return empty-intset (intset arg)))
- (($ $kargs _ _ ($ $prompt k kh src escape? tag))
- (return empty-intset (intset tag)))
- (($ $kargs _ _ ($ $throw src op param args))
- (return empty-intset (vars->intset args)))
- (($ $kclause arity body alt)
- (return (get-defs body) empty-intset))
- (($ $kreceive arity kargs)
- (return (get-defs kargs) empty-intset))
- (($ $ktail)
- (return empty-intset empty-intset))))
- cps
- empty-intmap
- empty-intmap)))
-
-(define (compute-reverse-control-flow-order preds)
- "Return a LABEL->ORDER bijection where ORDER is a contiguous set of
-integers starting from 0 and incrementing in sort order. There is a
-precondition that labels in PREDS are already renumbered in reverse post
-order."
- (define (has-back-edge? preds)
- (let/ec return
- (intmap-fold (lambda (label labels)
- (intset-fold (lambda (pred)
- (if (<= label pred)
- (return #t)
- (values)))
- labels)
- (values))
- preds)
- #f))
- (if (has-back-edge? preds)
- ;; This is more involved than forward control flow because not all
- ;; live labels are reachable from the tail.
- (persistent-intmap
- (fold2 (lambda (component order n)
- (intset-fold (lambda (label order n)
- (values (intmap-add! order label n)
- (1+ n)))
- component order n))
- (reverse (compute-sorted-strongly-connected-components preds))
- empty-intmap 0))
- ;; Just reverse forward control flow.
- (let ((max (intmap-prev preds)))
- (intmap-map (lambda (label labels) (- max label)) preds))))
-
(define* (add-prompt-control-flow-edges conts succs #:key complete?)
"For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
@@ -272,51 +185,6 @@ body continuation in the prompt."
conts
succs))
-(define (rename-keys map old->new)
- (persistent-intmap
- (intmap-fold (lambda (k v out)
- (intmap-add! out (intmap-ref old->new k) v))
- map
- empty-intmap)))
-
-(define (rename-intset set old->new)
- (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
- set empty-intset))
-
-(define (rename-graph graph old->new)
- (persistent-intmap
- (intmap-fold (lambda (pred succs out)
- (intmap-add! out
- (intmap-ref old->new pred)
- (rename-intset succs old->new)))
- graph
- empty-intmap)))
-
-(define (compute-live-variables cps defs uses)
- "Compute and return two values mapping LABEL->VAR..., where VAR... are
-the definitions that are live before and after LABEL, as intsets."
- (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
- (preds (invert-graph succs))
- (old->new (compute-reverse-control-flow-order preds))
- (init (persistent-intmap (intmap-fold
- (lambda (old new init)
- (intmap-add! init new empty-intset))
- old->new empty-intmap))))
- (call-with-values
- (lambda ()
- (solve-flow-equations (rename-graph preds old->new)
- init init
- (rename-keys defs old->new)
- (rename-keys uses old->new)
- intset-subtract intset-union intset-union))
- (lambda (in out)
- ;; As a reverse control-flow problem, the values flowing into a
- ;; node are actually the live values after the node executes.
- ;; Funny, innit? So we return them in the reverse order.
- (let ((new->old (invert-bijection old->new)))
- (values (rename-keys out new->old)
- (rename-keys in new->old)))))))
-
(define (compute-needs-slot cps defs uses)
(define (get-defs k) (intmap-ref defs k))
(define (get-uses label) (intmap-ref uses label))
@@ -746,84 +614,14 @@ are comparable with eqv?. A tmp slot may be used."
(persistent-intmap
(intmap-fold-right allocate-lazy cps slots)))
-(define (compute-var-representations cps)
- (define (get-defs k)
- (match (intmap-ref cps k)
- (($ $kargs names vars) vars)
- (_ '())))
- (intmap-fold
- (lambda (label cont representations)
- (match cont
- (($ $kargs _ _ ($ $continue k _ exp))
- (match (get-defs k)
- (() representations)
- ((var)
- (match exp
- (($ $values (arg))
- (intmap-add representations var
- (intmap-ref representations arg)))
- (($ $primcall (or 'scm->f64 'load-f64 's64->f64
- 'f32-ref 'f64-ref
- 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
- 'ffloor 'fceiling
- 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2))
- (intmap-add representations var 'f64))
- (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
- 's64->u64
- 'assume-u64
- 'uadd 'usub 'umul
- 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
- 'uadd/immediate 'usub/immediate 'umul/immediate
- 'ursh/immediate 'ulsh/immediate
- 'u8-ref 'u16-ref 'u32-ref 'u64-ref
- 'word-ref 'word-ref/immediate
- 'untag-char))
- (intmap-add representations var 'u64))
- (($ $primcall (or 'untag-fixnum
- 'assume-s64
- 'scm->s64 'load-s64 'u64->s64
- 'srsh 'srsh/immediate
- 's8-ref 's16-ref 's32-ref 's64-ref))
- (intmap-add representations var 's64))
- (($ $primcall (or 'pointer-ref/immediate
- 'tail-pointer-ref/immediate))
- (intmap-add representations var 'ptr))
- (($ $code)
- (intmap-add representations var 'u64))
- (_
- (intmap-add representations var 'scm))))
- (vars
- (match exp
- (($ $values args)
- (fold (lambda (arg var representations)
- (intmap-add representations var
- (intmap-ref representations arg)))
- representations args vars))))))
- (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
- representations)
- (($ $kfun src meta self tail entry)
- (let ((representations (if self
- (intmap-add representations self 'scm)
- representations)))
- (fold1 (lambda (var representations)
- (intmap-add representations var 'scm))
- (get-defs entry) representations)))
- (($ $kclause arity body alt)
- (fold1 (lambda (var representations)
- (intmap-add representations var 'scm))
- (get-defs body) representations))
- (($ $kreceive arity kargs)
- (fold1 (lambda (var representations)
- (intmap-add representations var 'scm))
- (get-defs kargs) representations))
- (($ $ktail) representations)))
- cps
- empty-intmap))
-
(define* (allocate-slots cps #:key (precolor-calls? #t))
(let*-values (((defs uses) (compute-defs-and-uses cps))
((representations) (compute-var-representations cps))
- ((live-in live-out) (compute-live-variables cps defs uses))
+ ((live-in live-out)
+ (let* ((succs (compute-successors cps))
+ (succs+ (add-prompt-control-flow-edges cps succs))
+ (preds (invert-graph succs+)))
+ (compute-live-variables preds defs uses)))
((needs-slot) (compute-needs-slot cps defs uses))
((lazy) (if precolor-calls?
(compute-lazy-vars cps live-in live-out defs
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 7657bf409..d3be176bf 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -2014,7 +2014,7 @@ maximum, where type is a bitset as a fixnum."
(match (intmap-ref conts k)
(($ $kargs _ defs)
(infer-primcall types 0 name param args
- (match defs ((var) var) (() #f))))
+ (match defs ((var) var) (_ #f))))
(_
;; (pk 'warning-no-restrictions name)
types))))
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index c72c04434..2b0c91c4b 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 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
@@ -43,7 +43,9 @@
compute-successors
compute-predecessors
compute-idoms
- compute-dom-edges)
+ compute-dom-edges
+ compute-defs-and-uses
+ compute-var-representations)
#:re-export (fold1 fold2
trivial-intset
intmap-map
@@ -302,42 +304,6 @@ intset."
(intmap-fold adjoin-idom preds-map idoms))
empty-intmap)))
-;; Precondition: For each function in CONTS, the continuation names are
-;; topologically sorted.
-(define (compute-idoms conts kfun)
- ;; This is the iterative O(n^2) fixpoint algorithm, originally from
- ;; Allen and Cocke ("Graph-theoretic constructs for program flow
- ;; analysis", 1972). See the discussion in Cooper, Harvey, and
- ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
- (let ((preds-map (compute-predecessors conts kfun)))
- (define (compute-idom idoms preds)
- (define (idom-ref label)
- (intmap-ref idoms label (lambda (_) #f)))
- (match preds
- (() -1)
- ((pred) pred) ; Shortcut.
- ((pred . preds)
- (define (common-idom d0 d1)
- ;; We exploit the fact that a reverse post-order is a
- ;; topological sort, and so the idom of a node is always
- ;; numerically less than the node itself.
- (let lp ((d0 d0) (d1 d1))
- (cond
- ;; d0 or d1 can be false on the first iteration.
- ((not d0) d1)
- ((not d1) d0)
- ((= d0 d1) d0)
- ((< d0 d1) (lp d0 (idom-ref d1)))
- (else (lp (idom-ref d0) d1)))))
- (fold1 common-idom preds pred))))
- (define (adjoin-idom label preds idoms)
- (let ((idom (compute-idom idoms preds)))
- ;; Don't use intmap-add! here.
- (intmap-add idoms label idom (lambda (old new) new))))
- (fixpoint (lambda (idoms)
- (intmap-fold adjoin-idom preds-map idoms))
- empty-intmap)))
-
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
(define (compute-dom-edges idoms)
@@ -351,3 +317,135 @@ intset."
idoms
empty-intmap)))
+(define (compute-defs-and-uses cps)
+ "Return two LABEL->VAR... maps indicating values defined at and used
+by a label, respectively."
+ (define (vars->intset vars)
+ (fold (lambda (var set) (intset-add set var)) empty-intset vars))
+ (define-syntax-rule (persistent-intmap2 exp)
+ (call-with-values (lambda () exp)
+ (lambda (a b)
+ (values (persistent-intmap a) (persistent-intmap b)))))
+ (persistent-intmap2
+ (intmap-fold
+ (lambda (label cont defs uses)
+ (define (get-defs k)
+ (match (intmap-ref cps k)
+ (($ $kargs names vars) (vars->intset vars))
+ (_ empty-intset)))
+ (define (return d u)
+ (values (intmap-add! defs label d)
+ (intmap-add! uses label u)))
+ (match cont
+ (($ $kfun src meta self tail clause)
+ (return (intset-union
+ (if clause (get-defs clause) empty-intset)
+ (if self (intset self) empty-intset))
+ empty-intset))
+ (($ $kargs _ _ ($ $continue k src exp))
+ (match exp
+ ((or ($ $const) ($ $const-fun) ($ $code))
+ (return (get-defs k) empty-intset))
+ (($ $call proc args)
+ (return (get-defs k) (intset-add (vars->intset args) proc)))
+ (($ $callk _ proc args)
+ (let ((args (vars->intset args)))
+ (return (get-defs k) (if proc (intset-add args proc) args))))
+ (($ $primcall name param args)
+ (return (get-defs k) (vars->intset args)))
+ (($ $values args)
+ (return (get-defs k) (vars->intset args)))))
+ (($ $kargs _ _ ($ $branch kf kt src op param args))
+ (return empty-intset (vars->intset args)))
+ (($ $kargs _ _ ($ $switch kf kt* src arg))
+ (return empty-intset (intset arg)))
+ (($ $kargs _ _ ($ $prompt k kh src escape? tag))
+ (return empty-intset (intset tag)))
+ (($ $kargs _ _ ($ $throw src op param args))
+ (return empty-intset (vars->intset args)))
+ (($ $kclause arity body alt)
+ (return (get-defs body) empty-intset))
+ (($ $kreceive arity kargs)
+ (return (get-defs kargs) empty-intset))
+ (($ $ktail)
+ (return empty-intset empty-intset))))
+ cps
+ empty-intmap
+ empty-intmap)))
+
+(define (compute-var-representations cps)
+ (define (get-defs k)
+ (match (intmap-ref cps k)
+ (($ $kargs names vars) vars)
+ (_ '())))
+ (intmap-fold
+ (lambda (label cont representations)
+ (match cont
+ (($ $kargs _ _ ($ $continue k _ exp))
+ (match (get-defs k)
+ (() representations)
+ ((var)
+ (match exp
+ (($ $values (arg))
+ (intmap-add representations var
+ (intmap-ref representations arg)))
+ (($ $primcall (or 'scm->f64 'load-f64 's64->f64
+ 'f32-ref 'f64-ref
+ 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
+ 'ffloor 'fceiling
+ 'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2))
+ (intmap-add representations var 'f64))
+ (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
+ 's64->u64
+ 'assume-u64
+ 'uadd 'usub 'umul
+ 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
+ 'uadd/immediate 'usub/immediate 'umul/immediate
+ 'ursh/immediate 'ulsh/immediate
+ 'u8-ref 'u16-ref 'u32-ref 'u64-ref
+ 'word-ref 'word-ref/immediate
+ 'untag-char))
+ (intmap-add representations var 'u64))
+ (($ $primcall (or 'untag-fixnum
+ 'assume-s64
+ 'scm->s64 'load-s64 'u64->s64
+ 'srsh 'srsh/immediate
+ 's8-ref 's16-ref 's32-ref 's64-ref))
+ (intmap-add representations var 's64))
+ (($ $primcall (or 'pointer-ref/immediate
+ 'tail-pointer-ref/immediate))
+ (intmap-add representations var 'ptr))
+ (($ $code)
+ (intmap-add representations var 'u64))
+ (_
+ (intmap-add representations var 'scm))))
+ (vars
+ (match exp
+ (($ $values args)
+ (fold (lambda (arg var representations)
+ (intmap-add representations var
+ (intmap-ref representations arg)))
+ representations args vars))))))
+ (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
+ representations)
+ (($ $kfun src meta self tail entry)
+ (let* ((representations (if self
+ (intmap-add representations self 'scm)
+ representations))
+ (defs (get-defs entry))
+ (reprs (or (assq-ref meta 'arg-representations)
+ (map (lambda (_) 'scm) defs))))
+ (fold (lambda (var repr representations)
+ (intmap-add representations var repr))
+ representations defs reprs)))
+ (($ $kclause arity body alt)
+ (fold1 (lambda (var representations)
+ (intmap-add representations var 'scm))
+ (get-defs body) representations))
+ (($ $kreceive arity kargs)
+ (fold1 (lambda (var representations)
+ (intmap-add representations var 'scm))
+ (get-defs kargs) representations))
+ (($ $ktail) representations)))
+ cps
+ empty-intmap))
diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm
index c495d2ae6..87d903c10 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/module/language/tree-il/compile-bytecode.scm
@@ -459,10 +459,10 @@
v)))
;; Transform "ash" to lsh / rsh.
- (($ <primcall> src 'ash (x ($ <const> src (? exact-integer? y))))
+ (($ <primcall> src 'ash (x ($ <const> src* (? exact-integer? y))))
(if (negative? y)
- (make-primcall src 'lsh (list x (make-const src (- y))))
- (make-primcall src 'rsh (list x (make-const src y)))))
+ (make-primcall src 'rsh (list x (make-const src* (- y))))
+ (make-primcall src 'lsh (list x (make-const src* y)))))
;; (throw key subr msg (list x) (list x))
(($ <primcall> src 'throw
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index ffc8308a6..918e9044a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1581,6 +1581,15 @@ use as the proc slot."
(letk ktail ($kargs ('tail) (tail) ,head))
($ (build-list ktail src vals))))))
+(define (sanitize-meta meta)
+ (match meta
+ (() '())
+ (((k . v) . meta)
+ (let ((meta (sanitize-meta meta)))
+ (case k
+ ((arg-representations) meta)
+ (else (acons k v meta)))))))
+
;;; The conversion from Tree-IL to CPS essentially wraps every
;;; expression in a $kreceive, which models the Tree-IL semantics that
;;; extra values are simply truncated. In CPS, this means that the
@@ -1865,7 +1874,7 @@ use as the proc slot."
(letv self)
(letk ktail ($ktail))
(let$ kclause (convert-clauses body ktail))
- (letk kfun ($kfun fun-src meta self ktail kclause))
+ (letk kfun ($kfun fun-src (sanitize-meta meta) self ktail kclause))
(let$ k (adapt-arity k fun-src 1))
(build-term ($continue k fun-src ($fun kfun))))
(let ((scope-id (fresh-scope-id)))
diff --git a/module/language/tree-il/inlinable-exports.scm b/module/language/tree-il/inlinable-exports.scm
new file mode 100644
index 000000000..8ea5725f3
--- /dev/null
+++ b/module/language/tree-il/inlinable-exports.scm
@@ -0,0 +1,869 @@
+;;; Attaching inlinable definitions of exported bindings to modules
+;;; Copyright (C) 2021
+;;; 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 License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+
+(define-module (language tree-il inlinable-exports)
+ #:use-module (ice-9 control)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il fix-letrec)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
+ #:use-module (srfi srfi-9)
+ #:use-module (system syntax)
+ #:use-module (rnrs bytevectors)
+ #:export (inlinable-exports))
+
+;;;
+;;; Inlining, as implemented by peval, is the mother of all
+;;; optimizations. It opens up space for other optimizations to work,
+;;; such as constant folding, conditional branch folding, and so on.
+;;;
+;;; Inlining works naturally for lexical bindings. Inlining of
+;;; top-level binding is facilitated by letrectification, which turns
+;;; top-level definition sequences to letrec*. Here we facilitate
+;;; inlining across module boundaries, so that module boundaries aren't
+;;; necessarily optimization boundaries.
+;;;
+;;; The high-level idea is to attach a procedure to the module being
+;;; compiled, which when called with a name of an export of that module
+;;; will return a Tree-IL expression that can be copied into the use
+;;; site. There are two parts: first we determine the set of inlinable
+;;; bindings, and then we compile that mapping to a procedure and attach
+;;; it to the program being compiled.
+;;;
+;;; Because we don't want inter-module inlining to inhibit intra-module
+;;; inlining, this pass is designed to run late in the Tree-IL
+;;; optimization pipeline -- after letrectification, after peval, and so
+;;; on. Unfortunately this does mean that we have to sometimes
+;;; pattern-match to determine higher-level constructs from lower-level
+;;; residual code, for example to map back from
+;;; module-ensure-local-variable! + %variable-set! to toplevel-define,
+;;; as reduced by letrectification. Ah well.
+;;;
+;;; Ultimately we want to leave the decision to peval as to what to
+;;; inline or not to inline, based on its size and effort counters. But
+;;; still we do need to impose some limits -- there's no sense in
+;;; copying a large constant from one module to another, for example.
+;;; Similarly there's no sense in copying a very large procedure.
+;;; Inspired by peval, we bound size growth via a counter that will
+;;; abort an inlinable attempt if the term is too large.
+;;;
+;;; Note that there are some semantic limitations -- you wouldn't want
+;;; to copy a mutable value, nor would you want to copy a closure with
+;;; free variables.
+;;;
+;;; Once the set of inlinables is determined, we copy them and rename
+;;; their lexicals. Any reference to an exported binding by lexical
+;;; variable is rewritten in terms of a reference to the exported
+;;; binding.
+;;;
+;;; The result is then compiled to a procedure, which internally has a
+;;; small interpreter for a bytecode, along with a set of constants.
+;;; The assumption is that most of the constants will be written to the
+;;; object file anyway, so we aren't taking up more space there. Any
+;;; non-immediate is built on demand, so we limit the impact of
+;;; including inlinable definitions on load-time relocations,
+;;; allocations, and heap space.
+;;;
+
+(define (compute-assigned-lexicals exp)
+ (define assigned-lexicals '())
+ (define (add-assigned-lexical! var)
+ (set! assigned-lexicals (cons var assigned-lexicals)))
+ ((make-tree-il-folder)
+ exp
+ (lambda (exp)
+ (match exp
+ (($ <lexical-set> _ _ var _)
+ (add-assigned-lexical! var)
+ (values))
+ (_ (values))))
+ (lambda (exp)
+ (values)))
+ assigned-lexicals)
+
+(define (compute-assigned-toplevels exp)
+ (define assigned-toplevels '())
+ (define (add-assigned-toplevel! mod name)
+ (set! assigned-toplevels (acons mod name assigned-toplevels)))
+ ((make-tree-il-folder)
+ exp
+ (lambda (exp)
+ (match exp
+ (($ <toplevel-set> _ mod name _)
+ (add-assigned-toplevel! mod name)
+ (values))
+ (($ <module-set> src mod name public? exp)
+ (unless public?
+ (add-assigned-toplevel! mod name))
+ (values))
+ (_ (values))))
+ (lambda (exp)
+ (values)))
+ assigned-toplevels)
+
+;;; FIXME: Record all bindings in a module, to know whether a
+;;; toplevel-ref is an import or not. If toplevel-ref to imported
+;;; variable, transform to module-ref or primitive-ref. New pass before
+;;; peval.
+
+(define (compute-module-bindings exp)
+ (define assigned-lexicals (compute-assigned-lexicals exp))
+ (define assigned-toplevels (compute-assigned-toplevels exp))
+ (define module-definitions '())
+ (define lexicals (make-hash-table))
+ (define module-lexicals '())
+ (define variable-lexicals '())
+ (define binding-lexicals '())
+ (define binding-values '())
+ (define (add-module-definition! mod args)
+ (set! module-definitions (acons mod args module-definitions)))
+ (define (add-lexical! var val)
+ (unless (memq var assigned-lexicals)
+ (hashq-set! lexicals var val)))
+ (define (add-module-lexical! var mod)
+ (unless (memq var assigned-lexicals)
+ (set! module-lexicals (acons var mod module-lexicals))))
+ (define (add-variable-lexical! var mod name)
+ (unless (memq var assigned-lexicals)
+ (set! variable-lexicals (acons var (cons mod name) variable-lexicals))))
+ (define (add-binding-lexical! var mod name)
+ (unless (memq var assigned-lexicals)
+ (set! binding-lexicals (acons var (cons mod name) binding-lexicals))))
+ (define (add-binding-value! mod name val)
+ (set! binding-values (acons (cons mod name) val binding-values)))
+
+ (define (record-bindings! mod gensyms vals)
+ (for-each
+ (lambda (var val)
+ (add-lexical! var val)
+ (match val
+ (($ <call> _ ($ <module-ref> _ '(guile) 'define-module* #f)
+ (($ <const> _ mod) . args))
+ (add-module-definition! mod args)
+ (add-module-lexical! var mod))
+ (($ <primcall> _ 'current-module ())
+ (when mod
+ (add-module-lexical! var mod)))
+ (($ <primcall> _ 'module-ensure-local-variable!
+ (($ <lexical-ref> _ _ mod-var) ($ <const> _ name)))
+ (let ((mod (assq-ref module-lexicals mod-var)))
+ (when mod
+ (add-variable-lexical! var mod name))))
+ (_ #f)))
+ gensyms vals))
+
+ ;; Thread a conservative idea of what the current module is through
+ ;; the visit. Visiting an expression returns the name of the current
+ ;; module when the expression completes, or #f if unknown. Record the
+ ;; define-module* forms, if any, and note any assigned or
+ ;; multiply-defined variables. Record definitions by matching
+ ;; toplevel-define forms, but also by matching separate
+ ;; module-ensure-local-variable! + %variable-set, as residualized by
+ ;; letrectification.
+ (define (visit exp) (visit/mod exp #f))
+ (define (visit* exps)
+ (unless (null? exps)
+ (visit (car exps))
+ (visit* (cdr exps))))
+ (define (visit+ exps mod)
+ (match exps
+ (() mod)
+ ((exp . exps)
+ (let lp ((mod' (visit/mod exp mod)) (exps exps))
+ (match exps
+ (() mod')
+ ((exp . exps)
+ (lp (and (equal? mod' (visit/mod exp mod)) mod')
+ exps)))))))
+ (define (visit/mod exp mod)
+ (match exp
+ ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <lexical-ref>)
+ ($ <module-ref>) ($ <toplevel-ref>))
+ mod)
+
+ (($ <call> _ ($ <module-ref> _ '(guile) 'set-current-module #f)
+ (($ <lexical-ref> _ _ var)))
+ (assq-ref module-lexicals var))
+
+ (($ <primcall> src '%variable-set! (($ <lexical-ref> _ _ var)
+ val))
+ (match (assq-ref variable-lexicals var)
+ ((mod . name)
+ (add-binding-value! mod name val)
+ ;; Also record lexical for eta-expanded bindings.
+ (match val
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f #f #f () (arg ...)
+ ($ <call> _
+ (and eta ($ <lexical-ref> _ _ var))
+ (($ <lexical-ref> _ _ arg) ...))
+ #f))
+ (add-binding-lexical! var mod name))
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f (not #f) #f () (arg ...)
+ ($ <primcall> _ 'apply
+ ((and eta ($ <lexical-ref> _ _ var))
+ ($ <lexical-ref> _ _ arg) ...))
+ #f))
+ (add-binding-lexical! var mod name))
+ (($ <lexical-ref> _ _ var)
+ (add-binding-lexical! var mod name))
+ (_ #f)))
+ (_ #f))
+ (visit/mod val mod))
+
+ (($ <call> _ proc args)
+ (visit proc)
+ (visit* args)
+ #f)
+
+ (($ <primcall> _ _ args)
+ ;; There is no primcall that sets the current module.
+ (visit+ args mod))
+
+ (($ <conditional> src test consequent alternate)
+ (visit+ (list consequent alternate) (visit/mod test mod)))
+
+ (($ <lexical-set> src name gensym exp)
+ (visit/mod exp mod))
+
+ (($ <toplevel-set> src mod name exp)
+ (visit/mod exp mod))
+
+ (($ <module-set> src mod name public? exp)
+ (visit/mod exp mod))
+
+ (($ <toplevel-define> src mod name exp)
+ (add-binding-value! mod name exp)
+ (visit/mod exp mod))
+
+ (($ <lambda> src meta body)
+ (when body (visit body))
+ mod)
+
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (visit* inits)
+ (visit body)
+ (when alternate (visit alternate))
+ (values))
+
+ (($ <seq> src head tail)
+ (visit/mod tail (visit/mod head mod)))
+
+ (($ <let> src names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <letrec> src in-order? names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <fix> src names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <let-values> src exp body)
+ (visit/mod body (visit/mod exp mod))
+ #f)
+
+ (($ <prompt> src escape-only? tag body handler)
+ (visit tag)
+ (visit body)
+ (visit handler)
+ #f)
+
+ (($ <abort> src tag args tail)
+ (visit tag)
+ (visit* args)
+ (visit tail)
+ #f)))
+
+ (visit exp)
+ (values module-definitions lexicals binding-lexicals binding-values))
+
+;; - define inlinable? predicate:
+;; exported && declarative && only references public vars && not too big
+;;
+;; - public := exported from a module, at -O2 and less.
+;; at -O3 and higher public just means defined in any module.
+(define (inlinable-exp mod exports lexicals binding-lexicals exp)
+ (define fresh-var!
+ (let ((counter 0))
+ (lambda ()
+ (let ((name (string-append "t" (number->string counter))))
+ (set! counter (1+ counter))
+ (string->symbol name)))))
+ (define (fresh-vars vars)
+ (match vars
+ (() '())
+ ((_ . vars) (cons (fresh-var!) (fresh-vars vars)))))
+ (define (add-bound-vars old new bound)
+ (match (vector old new)
+ (#(() ()) bound)
+ (#((old . old*) (new . new*))
+ (add-bound-vars old* new* (acons old new bound)))))
+ (let/ec return
+ (define (abort!) (return #f))
+ (define count!
+ ;; Same as default operator size limit for peval.
+ (let ((counter 40))
+ (lambda ()
+ (set! counter (1- counter))
+ (when (zero? counter) (abort!)))))
+ (define (residualize-module-private-ref src mod' name)
+ ;; TODO: At -O3, we could residualize a private
+ ;; reference. But that could break peoples'
+ ;; expectations.
+ (abort!))
+ (define (eta-reduce exp)
+ ;; Undo the result of eta-expansion pass.
+ (match exp
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f #f #f () (sym ...)
+ ($ <call> _
+ (and eta ($ <lexical-ref>)) (($ <lexical-ref> _ _ sym) ...))
+ #f))
+ eta)
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f (not #f) #f () (sym ...)
+ ($ <primcall> _ 'apply
+ ((and eta ($ <lexical-ref>)) ($ <lexical-ref> _ _ sym) ...))
+ #f))
+ eta)
+ (_ exp)))
+
+ (let copy ((exp (eta-reduce exp)) (bound '()) (in-lambda? #f))
+ (define (recur exp) (copy exp bound in-lambda?))
+ (count!)
+ (match exp
+ ((or ($ <void>) ($ <primitive-ref>) ($ <module-ref>))
+ exp)
+
+ (($ <const> src val)
+ (match val
+ ;; Don't copy values that could be "too big".
+ ((? string?) exp) ; Oddly, (array? "") => #t.
+ ((or (? pair?) (? syntax?) (? array?))
+ (abort!))
+ (_ exp)))
+
+ (($ <lexical-ref> src name var)
+ (cond
+ ;; Rename existing lexicals.
+ ((assq-ref bound var)
+ => (lambda (var)
+ (make-lexical-ref src name var)))
+ ;; A free variable reference to a lambda, outside a lambda.
+ ;; Could be the lexical-ref residualized by letrectification.
+ ;; Copy and rely on size limiter to catch runaways.
+ ((and (not in-lambda?) (lambda? (hashq-ref lexicals var)))
+ (recur (hashq-ref lexicals var)))
+ ((not in-lambda?)
+ ;; No advantage to "inline" a toplevel to another toplevel.
+ (abort!))
+ ;; Some letrectified toplevels will be bound to lexical
+ ;; variables, but unless the module has sealed private
+ ;; bindings, there may be an associated top-level variable
+ ;; as well.
+ ((assq-ref binding-lexicals var)
+ => (match-lambda
+ ((mod' . name)
+ (cond
+ ((and (equal? mod' mod) (assq-ref exports name))
+ => (lambda (public-name)
+ (make-module-ref src mod public-name #t)))
+ (else
+ (residualize-module-private-ref src mod' name))))))
+ ;; A free variable reference. If it's in the program at this
+ ;; point, that means that peval didn't see fit to copy it, so
+ ;; there's no point in trying to do so here.
+ (else (abort!))))
+
+ (($ <toplevel-ref> src mod' name)
+ (cond
+ ;; Rewrite private references to exported bindings into public
+ ;; references. Peval can decide whether to continue inlining
+ ;; or not.
+ ((and (equal? mod mod') (assq-ref exports name))
+ => (lambda (public-name)
+ (make-module-ref src mod public-name #t)))
+ (else
+ (residualize-module-private-ref src mod' name))))
+
+ (($ <call> src proc args)
+ (unless in-lambda? (abort!))
+ (make-call src (recur proc) (map recur args)))
+
+ (($ <primcall> src name args)
+ (unless in-lambda? (abort!))
+ (make-primcall src name (map recur args)))
+
+ (($ <conditional> src test consequent alternate)
+ (unless in-lambda? (abort!))
+ (make-conditional src (recur test)
+ (recur consequent) (recur alternate)))
+
+ (($ <lexical-set> src name var exp)
+ (unless in-lambda? (abort!))
+ (cond
+ ((assq-ref bound var)
+ => (lambda (var)
+ (make-lexical-set src name var (recur exp))))
+ (else
+ (abort!))))
+
+ ((or ($ <toplevel-set>)
+ ($ <module-set>)
+ ($ <toplevel-define>))
+ (abort!))
+
+ (($ <lambda> src meta body)
+ ;; Remove any lengthy docstring.
+ (let ((meta (filter-map (match-lambda
+ (('documentation . _) #f)
+ (pair pair))
+ meta)))
+ (make-lambda src meta (and body (copy body bound #t)))))
+
+ (($ <lambda-case> src req opt rest kw inits vars body alternate)
+ (unless in-lambda? (abort!))
+ (let* ((vars* (fresh-vars vars))
+ (bound (add-bound-vars vars vars* bound)))
+ (define (recur* exp) (copy exp bound #t))
+ (make-lambda-case src req opt rest
+ (match kw
+ (#f #f)
+ ((aok? . kws)
+ (cons aok?
+ (map
+ (match-lambda
+ ((kw name var)
+ (list kw name (assq-ref var bound))))
+ kws))))
+ (map recur* inits)
+ vars*
+ (recur* body)
+ (and alternate (recur alternate)))))
+
+ (($ <seq> src head tail)
+ (unless in-lambda? (abort!))
+ (make-seq src (recur head) (recur tail)))
+
+ (($ <let> src names vars vals body)
+ (unless in-lambda? (abort!))
+ (let* ((vars* (fresh-vars vars))
+ (bound (add-bound-vars vars vars* bound)))
+ (define (recur* exp) (copy exp bound #t))
+ (make-let src names vars* (map recur vals) (recur* body))))
+
+ (($ <letrec> src in-order? names vars vals body)
+ (unless in-lambda? (abort!))
+ (let* ((vars* (fresh-vars vars))
+ (bound (add-bound-vars vars vars* bound)))
+ (define (recur* exp) (copy exp bound #t))
+ (make-letrec src in-order? names vars* (map recur* vals)
+ (recur* body))))
+
+ (($ <fix> src names vars vals body)
+ (unless in-lambda? (abort!))
+ (let* ((vars* (fresh-vars vars))
+ (bound (add-bound-vars vars vars* bound)))
+ (define (recur* exp) (copy exp bound #t))
+ (make-fix src names vars* (map recur* vals)
+ (recur* body))))
+
+ (($ <let-values> src exp body)
+ (unless in-lambda? (abort!))
+ (make-let-values src (recur exp) (recur body)))
+
+ (($ <prompt> src escape-only? tag body handler)
+ (unless in-lambda? (abort!))
+ (make-prompt src escape-only?
+ (recur tag) (recur body) (recur handler)))
+
+ (($ <abort> src tag args tail)
+ (unless in-lambda? (abort!))
+ (make-abort src (recur tag) (map recur args) (recur tail)))))))
+
+(define (compute-inlinable-bindings exp)
+ "Traverse @var{exp}, extracting module-level definitions."
+
+ (define-values (modules lexicals binding-lexicals bindings)
+ (compute-module-bindings exp))
+
+ (define (kwarg-ref args kw kt kf)
+ (let lp ((args args))
+ (match args
+ (() (kf))
+ ((($ <const> _ (? keyword? kw')) val . args)
+ (if (eq? kw' kw)
+ (kt val)
+ (lp args)))
+ ((_ _ . args)
+ (lp args)))))
+ (define (kwarg-ref/const args kw kt kf)
+ (kwarg-ref args kw
+ (lambda (exp)
+ (match exp
+ (($ <const> _ val') (kt val'))
+ (_ (kf))))
+ kf))
+ (define (has-constant-initarg? args kw val)
+ (kwarg-ref/const args kw
+ (lambda (val')
+ (equal? val val'))
+ (lambda () #f)))
+
+ ;; Collect declarative modules defined once in this compilation unit.
+ (define modules-with-inlinable-exports
+ (let lp ((defs modules) (not-inlinable '()) (inlinable '()))
+ (match defs
+ (() inlinable)
+ (((mod . args) . defs)
+ (cond ((member mod not-inlinable)
+ (lp defs not-inlinable inlinable))
+ ((or (assoc mod defs) ;; doubly defined?
+ (not (has-constant-initarg? args #:declarative? #t)))
+ (lp defs (cons mod not-inlinable) inlinable))
+ (else
+ (lp defs not-inlinable (cons mod inlinable))))))))
+
+ ;; Omit multiply-defined bindings, and definitions not in declarative
+ ;; modules.
+ (define non-declarative-definitions
+ (let lp ((bindings bindings) (non-declarative '()))
+ (match bindings
+ (() non-declarative)
+ ((((and mod+name (mod . name)) . val) . bindings)
+ (cond
+ ((member mod+name non-declarative)
+ (lp bindings non-declarative))
+ ((or (assoc mod+name bindings)
+ (not (member mod modules-with-inlinable-exports)))
+ (lp bindings (cons mod+name non-declarative)))
+ (else
+ (lp bindings non-declarative)))))))
+
+ (define exports
+ (map (lambda (module)
+ (define args (assoc-ref modules module))
+ ;; Return list of (PRIVATE-NAME . PUBLIC-NAME) pairs.
+ (define (extract-exports kw)
+ (kwarg-ref/const args kw
+ (lambda (val)
+ (map (match-lambda
+ ((and pair (private . public)) pair)
+ (name (cons name name)))
+ val))
+ (lambda () '())))
+ (cons module
+ (append (extract-exports #:exports)
+ (extract-exports #:replacements))))
+ modules-with-inlinable-exports))
+
+ ;; Compute ((PRIVATE-NAME . PUBLIC-NAME) . VALUE) pairs for each
+ ;; module with inlinable bindings, for exported bindings only.
+ (define inlinable-candidates
+ (map
+ (lambda (module)
+ (define name-pairs (assoc-ref exports module))
+ (define (name-pair private-name)
+ (assq private-name name-pairs))
+ (cons module
+ (filter-map
+ (match-lambda
+ (((and mod+name (mod . name)) . val)
+ (and (equal? module mod)
+ (not (member mod+name non-declarative-definitions))
+ (and=> (name-pair name)
+ (lambda (pair) (cons pair val))))))
+ bindings)))
+ modules-with-inlinable-exports))
+
+ (define inlinables
+ (filter-map
+ (match-lambda
+ ((mod . exports)
+ (let ((name-pairs (map car exports)))
+ (match (filter-map
+ (match-lambda
+ (((private . public) . val)
+ (match (inlinable-exp mod name-pairs lexicals
+ binding-lexicals val)
+ (#f #f)
+ (val (cons public val)))))
+ exports)
+ (() #f)
+ (exports (cons mod exports))))))
+ inlinable-candidates))
+
+ inlinables)
+
+(define (put-uleb port val)
+ (let lp ((val val))
+ (let ((next (ash val -7)))
+ (if (zero? next)
+ (put-u8 port val)
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp next))))))
+
+(define (known-vtable vtable)
+ (define-syntax-rule (tree-il-case vt ...)
+ (cond
+ ((eq? vtable vt) (values '(language tree-il) 'vt))
+ ...
+ (else (values #f #f))))
+ (tree-il-case <void>
+ <const>
+ <primitive-ref>
+ <lexical-ref>
+ <lexical-set>
+ <module-ref>
+ <module-set>
+ <toplevel-ref>
+ <toplevel-set>
+ <toplevel-define>
+ <conditional>
+ <call>
+ <primcall>
+ <seq>
+ <lambda>
+ <lambda-case>
+ <let>
+ <letrec>
+ <fix>
+ <let-values>
+ <prompt>
+ <abort>))
+
+(define-record-type <encoding>
+ (%make-encoding constants vtables pair-code vector-code symbol-code next-code)
+ encoding?
+ (constants constants)
+ (vtables vtables)
+ (pair-code pair-code set-pair-code!)
+ (vector-code vector-code set-vector-code!)
+ (symbol-code symbol-code set-symbol-code!)
+ (next-code next-code set-next-code!))
+
+(define (make-encoding)
+ (%make-encoding (make-hash-table) (make-hash-table) #f #f #f 0))
+
+(define (vtable-nfields vtable)
+ (define vtable-index-size 5) ; FIXME: pull from struct.h
+ (struct-ref/unboxed vtable vtable-index-size))
+
+(define (build-encoding! term encoding)
+ (define (next-code!)
+ (let ((code (next-code encoding)))
+ (set-next-code! encoding (1+ code))
+ code))
+
+ (define (intern-constant! x)
+ (unless (hash-ref (constants encoding) x)
+ (hash-set! (constants encoding) x (next-code!))))
+ (define (intern-vtable! x)
+ (unless (hashq-ref (vtables encoding) x)
+ (hashq-set! (vtables encoding) x (next-code!))))
+ (define (ensure-pair-code!)
+ (unless (pair-code encoding)
+ (set-pair-code! encoding (next-code!))))
+ (define (ensure-vector-code!)
+ (unless (vector-code encoding)
+ (set-vector-code! encoding (next-code!))))
+ (define (ensure-symbol-code!)
+ (unless (symbol-code encoding)
+ (set-symbol-code! encoding (next-code!))))
+
+ (let visit ((term term))
+ (cond
+ ((pair? term)
+ (ensure-pair-code!)
+ (visit (car term))
+ (visit (cdr term)))
+ ((vector? term)
+ (ensure-vector-code!)
+ (visit (vector-length term))
+ (let lp ((i 0))
+ (when (< i (vector-length term))
+ (visit (vector-ref term i))
+ (lp (1+ i)))))
+ ((symbol? term)
+ (ensure-symbol-code!)
+ (visit (symbol->string term)))
+ ((struct? term)
+ (let ((vtable (struct-vtable term)))
+ (unless (known-vtable vtable)
+ (error "struct of unknown type" term))
+ (intern-vtable! vtable)
+ (let ((nfields (vtable-nfields vtable)))
+ (let lp ((i 0))
+ (when (< i nfields)
+ (visit (struct-ref term i))
+ (lp (1+ i)))))))
+ (else
+ (intern-constant! term)))))
+
+(define (compute-decoder encoding)
+ (define (pair-clause code)
+ `((eq? code ,code)
+ (let* ((car (lp))
+ (cdr (lp)))
+ (cons car cdr))))
+ (define (vector-clause code)
+ `((eq? code ,code)
+ (let* ((len (lp))
+ (v (make-vector len)))
+ (let init ((i 0))
+ (when (< i len)
+ (vector-set! v i (lp))
+ (init (1+ i))))
+ v)))
+ (define (symbol-clause code)
+ `((eq? code ,code)
+ (string->symbol (lp))))
+ (define (vtable-clause vtable code)
+ (call-with-values (lambda () (known-vtable vtable))
+ (lambda (mod name)
+ (let ((fields (map (lambda (i) (string->symbol (format #f "f~a" i)))
+ (iota (vtable-nfields vtable)))))
+ `((eq? code ,code)
+ (let* (,@(map (lambda (field) `(,field (lp))) fields))
+ (make-struct/no-tail (@ ,mod ,name) ,@fields)))))))
+ (define (constant-clause constant code)
+ `((eq? code ,code) ',constant))
+
+ `(lambda (bv)
+ (define pos 0)
+ (define (next-u8!)
+ (let ((u8 (bytevector-u8-ref bv pos)))
+ (set! pos (1+ pos))
+ u8))
+ (define (next-uleb!)
+ ,(if (< (next-code encoding) #x80)
+ ;; No need for uleb decoding in this case.
+ '(next-u8!)
+ ;; FIXME: We have a maximum code length and probably we
+ ;; should just inline the corresponding decoder instead of
+ ;; looping.
+ '(let lp ((n 0) (shift 0))
+ (let ((b (next-u8!)))
+ (if (zero? (logand b #x80))
+ (logior (ash b shift) n)
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (+ shift 7)))))))
+ (let lp ()
+ (let ((code (next-uleb!)))
+ (cond
+ ,@(if (pair-code encoding)
+ (list (pair-clause (pair-code encoding)))
+ '())
+ ,@(if (vector-code encoding)
+ (list (vector-clause (vector-code encoding)))
+ '())
+ ,@(if (symbol-code encoding)
+ (list (symbol-clause (symbol-code encoding)))
+ '())
+ ,@(hash-map->list vtable-clause (vtables encoding))
+ ,@(hash-map->list constant-clause (constants encoding))
+ (else (error "bad code" code)))))))
+
+(define (encode term encoding)
+ (call-with-output-bytevector
+ (lambda (port)
+ (define (put x) (put-uleb port x))
+ (let visit ((term term))
+ (cond
+ ((pair? term)
+ (put (pair-code encoding))
+ (visit (car term))
+ (visit (cdr term)))
+ ((vector? term)
+ (put (vector-code encoding))
+ (visit (vector-length term))
+ (let lp ((i 0))
+ (when (< i (vector-length term))
+ (visit (vector-ref term i))
+ (lp (1+ i)))))
+ ((symbol? term)
+ (put (symbol-code encoding))
+ (visit (symbol->string term)))
+ ((struct? term)
+ (let* ((vtable (struct-vtable term))
+ (nfields (vtable-nfields vtable)))
+ (put (hashq-ref (vtables encoding) vtable))
+ (let lp ((i 0))
+ (when (< i nfields)
+ (visit (struct-ref term i))
+ (lp (1+ i))))))
+ (else
+ (put (hash-ref (constants encoding) term))))))))
+
+(define (compute-encoding bindings)
+ (let ((encoding (make-encoding)))
+ (for-each (match-lambda
+ ((name . expr) (build-encoding! expr encoding)))
+ bindings)
+ (let ((encoded (map (match-lambda
+ ((name . expr) (cons name (encode expr encoding))))
+ bindings)))
+ `(lambda (name)
+ (define decode ,(compute-decoder encoding))
+ (cond
+ ,@(map (match-lambda
+ ((name . bv)
+ `((eq? name ',name) (decode ,bv))))
+ encoded)
+ (else #f))))))
+
+(define encoding-module (current-module))
+(define (compile-inlinable-exports bindings)
+ (let ((exp (compute-encoding bindings)))
+ (fix-letrec
+ (expand-primitives
+ (resolve-primitives
+ (compile-tree-il exp encoding-module '())
+ encoding-module)))))
+
+(define (attach-inlinables exp inlinables)
+ (post-order
+ (lambda (exp)
+ (match exp
+ (($ <call> src (and proc ($ <module-ref> _ '(guile) 'define-module* #f))
+ ((and m ($ <const> _ mod)) . args))
+ (cond
+ ((assoc-ref inlinables mod)
+ => (lambda (bindings)
+ (let ((inlinables (compile-inlinable-exports bindings)))
+ (make-call src proc
+ (cons* m
+ (make-const #f #:inlinable-exports)
+ inlinables
+ args)))))
+ (else exp)))
+ (exp exp)))
+ exp))
+
+(define (inlinable-exports exp)
+ (attach-inlinables exp (compute-inlinable-bindings exp)))
diff --git a/module/language/tree-il/letrectify.scm b/module/language/tree-il/letrectify.scm
index c27e75e60..60d057ffd 100644
--- a/module/language/tree-il/letrectify.scm
+++ b/module/language/tree-il/letrectify.scm
@@ -1,6 +1,6 @@
;;; transformation of top-level bindings into letrec*
-;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2019-2021 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
@@ -252,6 +252,24 @@
(add-statement src init (make-void src))))
mod-vars)))))))
+ (($ <let> src names vars vals body)
+ (let lp ((names names) (vars vars) (vals vals) (mod-vars mod-vars))
+ (match (vector names vars vals)
+ (#(() () ())
+ (values (visit-expr body) mod-vars))
+ (#((name . names) (var . vars) (val . vals))
+ (let* ((val (visit-expr val))
+ (mod-vars
+ (match val
+ (($ <call> _
+ ($ <module-ref> _ '(guile) 'define-module* #f)
+ (($ <const> _ mod) . args))
+ (acons mod var mod-vars))
+ (_ mod-vars))))
+ (let-values (((exp mod-vars) (lp names vars vals mod-vars)))
+ (values (add-binding name var val exp)
+ mod-vars)))))))
+
(($ <seq> src head tail)
(let*-values (((head mod-vars) (visit-top-level head mod-vars))
((tail mod-vars) (visit-top-level tail mod-vars)))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index c080bbbc2..b1d8b8294 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
;;; Tree-il optimizer
-;; Copyright (C) 2009, 2010-2015, 2018-2020 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010-2015, 2018-2021 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
@@ -39,22 +39,27 @@
'proc)))))
(let ((verify (or (lookup #:verify-tree-il? debug verify-tree-il)
(lambda (exp) exp)))
+ (modulify (lookup #:resolve-free-vars? resolve-free-vars))
(resolve (lookup #:resolve-primitives? primitives resolve-primitives))
(expand (lookup #:expand-primitives? primitives expand-primitives))
(letrectify (lookup #:letrectify? letrectify))
(seal? (assq-ref opts #:seal-private-bindings?))
+ (xinline? (assq-ref opts #:cross-module-inlining?))
(peval (lookup #:partial-eval? peval))
- (eta-expand (lookup #:eta-expand? eta-expand)))
+ (eta-expand (lookup #:eta-expand? eta-expand))
+ (inlinables (lookup #:inlinable-exports? inlinable-exports)))
(define-syntax-rule (run-pass! (proc exp arg ...))
(when proc (set! exp (verify (proc exp arg ...)))))
(lambda (exp env)
(verify exp)
+ (run-pass! (modulify exp))
(run-pass! (resolve exp env))
(run-pass! (expand exp))
(run-pass! (letrectify exp #:seal-private-bindings? seal?))
(run-pass! (fix-letrec exp))
- (run-pass! (peval exp env))
+ (run-pass! (peval exp env #:cross-module-inlining? xinline?))
(run-pass! (eta-expand exp))
+ (run-pass! (inlinables exp))
exp)))
(define (optimize x env opts)
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 123b40384..d910088c9 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -368,7 +368,8 @@
(operand-size-limit 20)
(value-size-limit 10)
(effort-limit 500)
- (recursive-effort-limit 100))
+ (recursive-effort-limit 100)
+ (cross-module-inlining? #f))
"Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression."
@@ -431,14 +432,54 @@ top-level bindings from ENV and return the resulting expression."
(define (lexical-refcount sym)
(var-refcount (lookup-var sym)))
+ (define (splice-expression exp)
+ (define vars (make-hash-table))
+ (define (rename! old*)
+ (match old*
+ (() '())
+ ((old . old*)
+ (cons (let ((new (gensym "t")))
+ (hashq-set! vars old new)
+ new)
+ (rename! old*)))))
+ (define (new-name old) (hashq-ref vars old))
+ (define renamed
+ (pre-order
+ (match-lambda
+ (($ <lexical-ref> src name gensym)
+ (make-lexical-ref src name (new-name gensym)))
+ (($ <lexical-set> src name gensym exp)
+ (make-lexical-set src name (new-name gensym) exp))
+ (($ <lambda-case> src req opt rest kw init gensyms body alt)
+ (let ((gensyms (rename! gensyms)))
+ (make-lambda-case src req opt rest
+ (match kw
+ ((aok? (kw name sym) ...)
+ (cons aok?
+ (map (lambda (kw name sym)
+ (list kw name (new-name sym)))
+ kw name sym)))
+ (#f #f))
+ init gensyms body alt)))
+ (($ <let> src names gensyms vals body)
+ (make-let src names (rename! gensyms) vals body))
+ (($ <letrec>)
+ (error "unexpected letrec"))
+ (($ <fix> src names gensyms vals body)
+ (make-fix src names (rename! gensyms) vals body))
+ (exp exp))
+ exp))
+ (set! store (build-var-table renamed store))
+ renamed)
+
(define (with-temporaries src exps refcount can-copy? k)
(let* ((pairs (map (match-lambda
- ((and exp (? can-copy?))
- (cons #f exp))
- (exp
- (let ((sym (gensym "tmp ")))
- (record-new-temporary! 'tmp sym refcount)
- (cons sym exp))))
+ ((and exp (? can-copy?))
+ (cons #f exp))
+ (exp
+ (let ((sym (gensym "tmp ")))
+ (record-new-temporary! 'tmp sym refcount)
+ (cons sym exp))))
exps))
(tmps (filter car pairs)))
(match tmps
@@ -449,9 +490,9 @@ top-level bindings from ENV and return the resulting expression."
(map car tmps)
(map cdr tmps)
(k (map (match-lambda
- ((#f . val) val)
- ((sym . _)
- (make-lexical-ref #f 'tmp sym)))
+ ((#f . val) val)
+ ((sym . _)
+ (make-lexical-ref #f 'tmp sym)))
pairs)))))))
(define (make-begin0 src first second)
@@ -506,14 +547,14 @@ top-level bindings from ENV and return the resulting expression."
(define (apply-primitive name args)
;; todo: further optimize commutative primitives
(catch #t
- (lambda ()
- (call-with-values
- (lambda ()
- (apply (module-ref the-scm-module name) args))
- (lambda results
- (values #t results))))
- (lambda _
- (values #f '()))))
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (apply (module-ref the-scm-module name) args))
+ (lambda results
+ (values #t results))))
+ (lambda _
+ (values #f '()))))
(define (make-values src values)
(match values
((single) single) ; 1 value
@@ -1027,8 +1068,45 @@ top-level bindings from ENV and return the resulting expression."
(make-primitive-ref src name)
exp))
exp)))
- (($ <module-ref>)
- exp)
+ (($ <module-ref> src module name public?)
+ (cond
+ ((and cross-module-inlining?
+ public?
+ (and=> (resolve-interface module)
+ (lambda (module)
+ (and=> (module-inlinable-exports module)
+ (lambda (proc) (proc name))))))
+ => (lambda (inlined)
+ ;; Similar logic to lexical-ref, but we can't enumerate
+ ;; uses, and don't know about aliases.
+ (log 'begin-xm-copy exp inlined)
+ (cond
+ ((eq? ctx 'effect)
+ (log 'xm-effect)
+ (make-void #f))
+ ((eq? ctx 'call)
+ ;; Don't propagate copies if we are residualizing a call.
+ (log 'residualize-xm-call exp)
+ exp)
+ ((or (const? inlined) (void? inlined) (primitive-ref? inlined))
+ ;; Always propagate simple values that cannot lead to
+ ;; code bloat.
+ (log 'copy-xm-const)
+ (for-tail inlined))
+ ;; Inline in operator position if it's a lambda that's
+ ;; small enough. Normally the inlinable-exports pass
+ ;; will only make small lambdas available for inlining,
+ ;; but you never know.
+ ((and (eq? ctx 'operator) (lambda? inlined)
+ (small-expression? inlined operator-size-limit))
+ (log 'copy-xm-operator exp inlined)
+ (splice-expression inlined))
+ (else
+ (log 'xm-copy-failed)
+ ;; Could copy small lambdas in value context. Something
+ ;; to revisit.
+ exp))))
+ (else exp)))
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (for-value exp)))
(($ <toplevel-define> src mod name exp)
@@ -1146,55 +1224,55 @@ top-level bindings from ENV and return the resulting expression."
(with-temporaries
src (list w u) 2 constant-expression?
(match-lambda
- ((w u)
- (make-seq
- src
+ ((w u)
(make-seq
src
- (make-conditional
+ (make-seq
src
- ;; fixme: introduce logic to fold thunk?
- (make-primcall src 'thunk? (list u))
- (make-call src w '())
- (make-primcall
- src 'throw
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "dynamic-wind")
- (make-const #f "Wrong type (expecting thunk): ~S")
- (make-primcall #f 'list (list u))
- (make-primcall #f 'list (list u)))))
- (make-primcall src 'wind (list w u)))
- (make-begin0 src
- (make-call src thunk '())
- (make-seq src
- (make-primcall src 'unwind '())
- (make-call src u '())))))))))
+ (make-conditional
+ src
+ ;; fixme: introduce logic to fold thunk?
+ (make-primcall src 'thunk? (list u))
+ (make-call src w '())
+ (make-primcall
+ src 'throw
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list u))
+ (make-primcall #f 'list (list u)))))
+ (make-primcall src 'wind (list w u)))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-seq src
+ (make-primcall src 'unwind '())
+ (make-call src u '())))))))))
(($ <primcall> src 'with-fluid* (f v thunk))
(for-tail
(with-temporaries
src (list f v thunk) 1 constant-expression?
(match-lambda
- ((f v thunk)
- (make-seq src
- (make-primcall src 'push-fluid (list f v))
- (make-begin0 src
- (make-call src thunk '())
- (make-primcall src 'pop-fluid '()))))))))
+ ((f v thunk)
+ (make-seq src
+ (make-primcall src 'push-fluid (list f v))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-primcall src 'pop-fluid '()))))))))
(($ <primcall> src 'with-dynamic-state (state thunk))
(for-tail
(with-temporaries
src (list state thunk) 1 constant-expression?
(match-lambda
- ((state thunk)
- (make-seq src
- (make-primcall src 'push-dynamic-state (list state))
- (make-begin0 src
- (make-call src thunk '())
- (make-primcall src 'pop-dynamic-state
- '()))))))))
+ ((state thunk)
+ (make-seq src
+ (make-primcall src 'push-dynamic-state (list state))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-primcall src 'pop-dynamic-state
+ '()))))))))
(($ <primcall> src 'values exps)
(cond
@@ -1379,7 +1457,7 @@ top-level bindings from ENV and return the resulting expression."
(((? equality-primitive?) (and a ($ <const>)) b)
(for-tail (make-primcall src name (list b a))))
(((? equality-primitive?) ($ <lexical-ref> _ _ sym)
- ($ <lexical-ref> _ _ sym))
+ ($ <lexical-ref> _ _ sym))
(for-tail (make-const src #t)))
(('logbit? ($ <const> src2
@@ -1660,8 +1738,8 @@ top-level bindings from ENV and return the resulting expression."
($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
(not (tree-il-any
(match-lambda
- (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
- (_ #f))
+ (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+ (_ #f))
body)))
(else #f)))
(if (and (not escape-only?) (escape-only-handler? handler))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 1cc7907a8..7f3746b4f 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -48,6 +48,7 @@
memq memv
= < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo exact->inexact
+ expt
ash logand logior logxor lognot logtest logbit?
sqrt abs floor ceiling sin cos tan asin acos atan
not
@@ -171,7 +172,7 @@
`(values
eq? eqv? equal?
= < > <= >= zero? positive? negative?
- ash logand logior logxor lognot logtest logbit?
+ expt ash logand logior logxor lognot logtest logbit?
+ * - / 1- 1+ sqrt abs quotient remainder modulo exact->inexact
floor ceiling sin cos tan asin acos atan
not
diff --git a/module/language/tree-il/resolve-free-vars.scm b/module/language/tree-il/resolve-free-vars.scm
new file mode 100644
index 000000000..3d4eb2bb0
--- /dev/null
+++ b/module/language/tree-il/resolve-free-vars.scm
@@ -0,0 +1,282 @@
+;;; Resolving free top-level references to modules
+;;; Copyright (C) 2021
+;;; 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 License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+
+(define-module (language tree-il resolve-free-vars)
+ #:use-module (ice-9 match)
+ #:use-module (language tree-il)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
+ #:export (resolve-free-vars))
+
+(define (compute-assigned-lexicals exp)
+ (define assigned-lexicals '())
+ (define (add-assigned-lexical! var)
+ (set! assigned-lexicals (cons var assigned-lexicals)))
+ ((make-tree-il-folder)
+ exp
+ (lambda (exp)
+ (match exp
+ (($ <lexical-set> _ _ var _)
+ (add-assigned-lexical! var)
+ (values))
+ (_ (values))))
+ (lambda (exp)
+ (values)))
+ assigned-lexicals)
+
+(define (make-resolver mod local-definitions)
+ ;; Given that module A imports B and C, and X is free in A,
+ ;; unfortunately there are a few things preventing us from knowing
+ ;; whether the binding proceeds from B or C, just based on the text:
+ ;;
+ ;; - Renamers are evaluated at run-time.
+ ;; - Just using B doesn't let us know what definitions are in B.
+ ;;
+ ;; So instead of using the source program to determine where a binding
+ ;; comes from, we use the first-class module interface.
+ (define (imported-resolver iface)
+ (let ((public-iface (resolve-interface (module-name iface))))
+ (if (eq? iface public-iface)
+ (lambda (name)
+ (and (module-variable iface name)
+ (cons (module-name iface) name)))
+ (let ((by-var (make-hash-table)))
+ (module-for-each (lambda (name var)
+ (hashq-set! by-var var name))
+ public-iface)
+ (lambda (name)
+ (let ((var (module-variable iface name)))
+ (and var
+ (cons (module-name iface)
+ (hashq-ref by-var var)))))))))
+
+ (define the-module (resolve-module mod))
+ (define resolvers
+ (map imported-resolver (module-uses the-module)))
+
+ (lambda (name)
+ (cond
+ ((or (module-local-variable the-module name)
+ (memq name local-definitions))
+ 'local)
+ (else
+ (match (filter-map (lambda (resolve) (resolve name)) resolvers)
+ (() 'unknown)
+ (((mod . #f)) 'unknown)
+ (((mod . public-name)) (cons mod public-name))
+ ((_ _ . _) 'duplicate))))))
+
+;;; Record all bindings in a module, to know whether a toplevel-ref is
+;;; an import or not. If toplevel-ref to imported variable, transform
+;;; to module-ref or primitive-ref. New pass before peval.
+
+(define (compute-free-var-resolver exp)
+ (define assigned-lexicals (compute-assigned-lexicals exp))
+ (define module-definitions '())
+ (define module-lexicals '())
+ (define bindings '())
+ (define (add-module-definition! mod args)
+ (set! module-definitions (acons mod args module-definitions)))
+ (define (add-module-lexical! var mod)
+ (unless (memq var assigned-lexicals)
+ (set! module-lexicals (acons var mod module-lexicals))))
+ (define (add-binding! mod name)
+ (set! bindings (acons mod name bindings)))
+
+ (define (record-bindings! mod vars vals)
+ (for-each
+ (lambda (var val)
+ (match val
+ (($ <call> _ ($ <module-ref> _ '(guile) 'define-module* #f)
+ (($ <const> _ mod) . args))
+ (add-module-definition! mod args)
+ (add-module-lexical! var mod))
+ (($ <primcall> _ 'current-module ())
+ (when mod
+ (add-module-lexical! var mod)))
+ (_ #f)))
+ vars vals))
+
+ ;; Thread a conservative idea of what the current module is through
+ ;; the visit. Visiting an expression returns the name of the current
+ ;; module when the expression completes, or #f if unknown. Record the
+ ;; define-module* forms, if any, and note any toplevel definitions.
+ (define (visit exp) (visit/mod exp #f))
+ (define (visit* exps)
+ (unless (null? exps)
+ (visit (car exps))
+ (visit* (cdr exps))))
+ (define (visit+ exps mod)
+ (match exps
+ (() mod)
+ ((exp . exps)
+ (let lp ((mod' (visit/mod exp mod)) (exps exps))
+ (match exps
+ (() mod')
+ ((exp . exps)
+ (lp (and (equal? mod' (visit/mod exp mod)) mod')
+ exps)))))))
+ (define (visit/mod exp mod)
+ (match exp
+ ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <lexical-ref>)
+ ($ <module-ref>) ($ <toplevel-ref>))
+ mod)
+
+ (($ <call> _ ($ <module-ref> _ '(guile) 'set-current-module #f)
+ (($ <lexical-ref> _ _ var)))
+ (assq-ref module-lexicals var))
+
+ (($ <call> _ proc args)
+ (visit proc)
+ (visit* args)
+ #f)
+
+ (($ <primcall> _ _ args)
+ ;; There is no primcall that sets the current module.
+ (visit+ args mod))
+
+ (($ <conditional> src test consequent alternate)
+ (visit+ (list consequent alternate) (visit/mod test mod)))
+
+ (($ <lexical-set> src name gensym exp)
+ (visit/mod exp mod))
+
+ (($ <toplevel-set> src mod name exp)
+ (visit/mod exp mod))
+
+ (($ <module-set> src mod name public? exp)
+ (visit/mod exp mod))
+
+ (($ <toplevel-define> src mod name exp)
+ (add-binding! mod name)
+ (visit/mod exp mod))
+
+ (($ <lambda> src meta body)
+ (when body (visit body))
+ mod)
+
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (visit* inits)
+ (let* ((bodies (cons body inits))
+ (bodies (if alternate (cons alternate bodies) bodies)))
+ (visit+ bodies mod)))
+
+ (($ <seq> src head tail)
+ (visit/mod tail (visit/mod head mod)))
+
+ (($ <let> src names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <letrec> src in-order? names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <fix> src names gensyms vals body)
+ (record-bindings! mod gensyms vals)
+ (visit/mod body (visit+ vals mod)))
+
+ (($ <let-values> src exp body)
+ (visit/mod body (visit/mod exp mod)))
+
+ (($ <prompt> src escape-only? tag body handler)
+ (visit+ (list body handler) (visit/mod tag mod)))
+
+ (($ <abort> src tag args tail)
+ (visit tag)
+ (visit* args)
+ (visit tail)
+ #f)))
+
+ (visit exp)
+
+ (define (kwarg-ref args kw kt kf)
+ (let lp ((args args))
+ (match args
+ (() (kf))
+ ((($ <const> _ (? keyword? kw')) val . args)
+ (if (eq? kw' kw)
+ (kt val)
+ (lp args)))
+ ((_ _ . args)
+ (lp args)))))
+ (define (kwarg-ref/const args kw kt kf)
+ (kwarg-ref args kw
+ (lambda (exp)
+ (match exp
+ (($ <const> _ val') (kt val'))
+ (_ (kf))))
+ kf))
+ (define (has-constant-initarg? args kw val)
+ (kwarg-ref/const args kw
+ (lambda (val')
+ (equal? val val'))
+ (lambda () #f)))
+
+ ;; Collect declarative modules defined once in this compilation unit.
+ (define declarative-modules
+ (let lp ((defs module-definitions) (not-declarative '()) (declarative '()))
+ (match defs
+ (() declarative)
+ (((mod . args) . defs)
+ (cond ((member mod not-declarative)
+ (lp defs not-declarative declarative))
+ ((or (assoc mod defs) ;; doubly defined?
+ (not (has-constant-initarg? args #:declarative? #t)))
+ (lp defs (cons mod not-declarative) declarative))
+ (else
+ (lp defs not-declarative (cons mod declarative))))))))
+
+ (define resolvers
+ (map (lambda (mod)
+ (define resolve
+ (make-resolver mod
+ (filter-map (match-lambda
+ ((mod' . name)
+ (and (equal? mod mod') name)))
+ bindings)))
+ (cons mod resolve))
+ declarative-modules))
+
+ (lambda (mod name)
+ (cond
+ ((assoc-ref resolvers mod)
+ => (lambda (resolve) (resolve name)))
+ (else 'unknown))))
+
+(define (resolve-free-vars exp)
+ "Traverse @var{exp}, extracting module-level definitions."
+ (define resolve
+ (compute-free-var-resolver exp))
+
+ (post-order
+ (lambda (exp)
+ (match exp
+ (($ <toplevel-ref> src mod name)
+ (match (resolve mod name)
+ ((or 'unknown 'duplicate 'local) exp)
+ ((mod . name)
+ (make-module-ref src mod name #t))))
+ (($ <toplevel-set> src mod name val)
+ (match (resolve mod name)
+ ((or 'unknown 'duplicate 'local) exp)
+ ((mod . name)
+ (make-module-set src mod name #t val))))
+ (exp exp)))
+ exp))
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index 20e280467..c6a73c092 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -56,10 +56,8 @@
bytevector bytevector-append
string->vector vector->string
(r7:string->utf8 . string->utf8)
- (r7:vector-copy . vector-copy)
(r7:vector->list . vector->list)
- (r7:vector-fill! . vector-fill!)
- vector-copy! vector-append vector-for-each vector-map
+ vector-append vector-for-each vector-map
(r7:bytevector-copy . bytevector-copy)
(r7:bytevector-copy! . bytevector-copy!)
(r7:utf8->string . utf8->string)
@@ -116,7 +114,7 @@
(char-ready? . u8-ready?)
unless
unquote unquote-splicing values
- vector
+ vector vector-copy vector-copy! vector-fill!
vector-length vector-ref vector-set! vector?
when with-exception-handler write-char
zero?))
@@ -433,41 +431,11 @@
;;; vector
-(define (%subvector v start end)
- (define mlen (- end start))
- (define out (make-vector (- end start)))
- (define (itr r)
- (if (= r mlen)
- out
- (begin
- (vector-set! out r (vector-ref v (+ start r)))
- (itr (+ r 1)))))
- (itr 0))
-
-(define r7:vector-copy
- (case-lambda*
- ((v) (vector-copy v))
- ((v start #:optional (end (vector-length v)))
- (%subvector v start end))))
-
-(define* (vector-copy! target tstart source
- #:optional (sstart 0) (send (vector-length source)))
- "Copy a block of elements from SOURCE to TARGET, both of which must be
-vectors, starting in TARGET at TSTART and starting in SOURCE at SSTART,
-ending when SEND - SSTART elements have been copied. It is an error for
-TARGET to have a length less than TSTART + (SEND - SSTART). SSTART
-defaults to 0 and SEND defaults to the length of SOURCE."
- (let ((tlen (vector-length target))
- (slen (vector-length source)))
- (if (< tstart sstart)
- (vector-move-left! source sstart send target tstart)
- (vector-move-right! source sstart send target tstart))))
-
(define r7:vector->list
(case-lambda*
((v) (vector->list v))
((v start #:optional (end (vector-length v)))
- (vector->list (%subvector v start end)))))
+ (vector->list (vector-copy v start end)))))
(define vector-map
(case-lambda*
@@ -518,16 +486,7 @@ defaults to 0 and SEND defaults to the length of SOURCE."
(case-lambda*
((v) (list->string (vector->list v)))
((v start #:optional (end (vector-length v)))
- (vector->string (%subvector v start end)))))
-
-(define r7:vector-fill!
- (case-lambda*
- ((vec fill) (vector-fill! vec fill))
- ((vec fill start #:optional (end (vector-length vec)))
- (let lp ((r start))
- (unless (= r end)
- (vector-set! vec r fill)
- (lp (+ r 1)))))))
+ (vector->string (vector-copy v start end)))))
(define (%subbytevector bv start end)
(define mlen (- end start))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 680ee94b5..57f9058b6 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014, 2020, 2021 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
@@ -734,7 +734,7 @@ the list returned."
(define (find-tail pred lst)
"Return the first pair of @var{lst} whose @sc{car} satisfies the
predicate @var{pred}, or return @code{#f} if no such element is found."
- (check-arg procedure? pred find)
+ (check-arg procedure? pred find-tail)
(let loop ((lst lst))
(and (not (null? lst))
(let ((head (car lst)))
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index eb6d8c317..18e97cf53 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -22,7 +22,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:re-export (make-vector vector vector? vector-ref vector-set!
- vector-length vector-fill!)
+ vector-length vector-fill! vector-copy!)
#:replace (vector-copy list->vector vector->list)
#:export (vector-empty? vector= vector-unfold vector-unfold-right
vector-reverse-copy
@@ -35,7 +35,7 @@
vector-binary-search
vector-any vector-every
vector-swap! vector-reverse!
- vector-copy! vector-reverse-copy!
+ vector-reverse-copy!
reverse-vector->list
reverse-list->vector))
@@ -204,7 +204,6 @@ error for the number of seeds to vary between iterations."
(define guile-vector-copy (@ (guile) vector-copy))
-;; TODO: Enhance Guile core 'vector-copy' to do this.
(define vector-copy
(case-lambda*
"(vector-copy vec [start [end [fill]]]) -> vector
@@ -217,23 +216,20 @@ VEC, the slots in the new vector that obviously cannot be filled by
elements from VEC are filled with FILL, whose default value is
unspecified."
((v) (guile-vector-copy v))
- ((v start)
- (assert-vector v 'vector-copy)
- (let ((len (vector-length v)))
- (assert-valid-start start len 'vector-copy)
- (let ((result (make-vector (- len start))))
- (vector-move-left! v start len result 0)
- result)))
+ ((v start) (guile-vector-copy v start))
((v start end #:optional (fill *unspecified*))
(assert-vector v 'vector-copy)
(let ((len (vector-length v)))
- (unless (and (exact-integer? start)
- (exact-integer? end)
- (<= 0 start end))
- (error-from 'vector-copy "invalid index range" start end))
- (let ((result (make-vector (- end start) fill)))
- (vector-move-left! v start (min end len) result 0)
- result)))))
+ (if (<= end len)
+ (guile-vector-copy v start end)
+ (begin
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start end))
+ (error-from 'vector-copy "invalid index range" start end))
+ (let ((result (make-vector (- end start) fill)))
+ (vector-move-left! v start (min end len) result 0)
+ result)))))))
(define vector-reverse-copy
(let ()
@@ -937,19 +933,6 @@ START defaults to 0 and END defaults to the length of VEC."
(error-from 'copy! "would write past end of target"))
(%copy! target tstart source sstart send)))))))
-(define-vector-copier! vector-copy!
- "(vector-copy! target tstart source [sstart [send]]) -> unspecified
-
-Copy a block of elements from SOURCE to TARGET, both of which must be
-vectors, starting in TARGET at TSTART and starting in SOURCE at
-SSTART, ending when SEND - SSTART elements have been copied. It is an
-error for TARGET to have a length less than TSTART + (SEND - SSTART).
-SSTART defaults to 0 and SEND defaults to the length of SOURCE."
- (lambda (target tstart source sstart send)
- (if (< tstart sstart)
- (vector-move-left! source sstart send target tstart)
- (vector-move-right! source sstart send target tstart))))
-
(define-vector-copier! vector-reverse-copy!
"(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 03c57bf1b..8da908da6 100644
--- a/module/system/base/optimize.scm
+++ b/module/system/base/optimize.scm
@@ -1,6 +1,6 @@
;;; Optimization flags
-;; Copyright (C) 2018, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2018, 2020, 2021 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
@@ -28,12 +28,15 @@
(match lang-name
('tree-il
'((#:cps? 2)
+ (#:resolve-free-vars? 1)
(#:resolve-primitives? 1)
(#:expand-primitives? 1)
(#:letrectify? 2)
(#:seal-private-bindings? 3)
(#:partial-eval? 1)
- (#:eta-expand? 2)))
+ (#:eta-expand? 2)
+ (#:inlinable-exports? 1)
+ (#:cross-module-inlining? 2)))
('cps
'( ;; (#:split-rec? #t)
(#:simplify? 2)
diff --git a/module/system/foreign-library.scm b/module/system/foreign-library.scm
index d53e293ef..dc426385f 100644
--- a/module/system/foreign-library.scm
+++ b/module/system/foreign-library.scm
@@ -48,7 +48,7 @@
(define system-library-extensions
(cond
- ((string-contains %host-type "-darwin-")
+ ((string-contains %host-type "-darwin")
'(".bundle" ".so" ".dylib"))
((or (string-contains %host-type "cygwin")
(string-contains %host-type "mingw")
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index ac1fa0933..0024fd165 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2020, 2021 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
@@ -22,10 +22,12 @@
(define-module (system repl command)
#:use-module (system base syntax)
#:use-module (system base pmatch)
- #:use-module (system base compile)
+ #:autoload (system base compile) (compile-file)
#:use-module (system repl common)
#:use-module (system repl debug)
- #:use-module (system vm disassembler)
+ #:autoload (system vm disassembler) (disassemble-image
+ disassemble-program
+ disassemble-file)
#:use-module (system vm loader)
#:use-module (system vm program)
#:use-module (system vm trap-state)
@@ -42,7 +44,7 @@
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (rnrs bytevectors)
- #:use-module (statprof)
+ #:autoload (statprof) (statprof)
#:export (meta-command define-meta-command))
@@ -55,7 +57,7 @@
(module (module m) (import use) (load l) (reload re) (binding b) (in))
(language (language L))
(compile (compile c) (compile-file cc)
- (expand exp) (optimize opt)
+ (expand exp) (optimize opt) (optimize-cps optx)
(disassemble x) (disassemble-file xx))
(profile (time t) (profile pr) (trace tr))
(debug (backtrace bt) (up) (down) (frame fr)
@@ -488,6 +490,11 @@ Run the optimizer on a piece of code and print the result."
(run-hook before-print-hook x)
(pp x)))
+(define-meta-command (optimize-cps repl (form))
+ "optimize-cps EXP
+Run the CPS optimizer on a piece of code and print the result."
+ (repl-optimize-cps repl (repl-parse repl form)))
+
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 29ae104c5..7f785b53e 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -32,7 +32,7 @@
repl-tm-stats repl-gc-stats repl-debug
repl-welcome repl-prompt
repl-read repl-compile repl-prepare-eval-thunk repl-eval
- repl-expand repl-optimize
+ repl-expand repl-optimize repl-optimize-cps
repl-parse repl-print repl-option-ref repl-option-set!
repl-default-option-set! repl-default-prompt-set!
puts ->string user-error
@@ -204,7 +204,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
#:env (current-module))
#:from lang #:to from)))
-(define* (repl-optimize repl form #:key (lang 'tree-il))
+(define (optimize* repl form lang print)
(let ((from (repl-language repl))
(make-lower (language-lowerer (lookup-language lang)))
(optimization-level (repl-optimization-level repl))
@@ -212,13 +212,21 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(opts (repl-compile-options repl)))
(unless make-lower
(error "language has no optimizer" lang))
- (decompile ((make-lower optimization-level opts)
- (compile form #:from from #:to lang #:opts opts
- #:optimization-level optimization-level
- #:warning-level warning-level
- #:env (current-module))
- (current-module))
- #:from lang #:to from)))
+ (print ((make-lower optimization-level opts)
+ (compile form #:from from #:to lang #:opts opts
+ #:optimization-level optimization-level
+ #:warning-level warning-level
+ #:env (current-module))
+ (current-module)))))
+
+(define* (repl-optimize repl form #:key (lang 'tree-il))
+ (optimize* repl form lang
+ (lambda (exp)
+ (decompile exp #:from lang #:to (repl-language repl)))))
+
+(define* (repl-optimize-cps repl form)
+ (optimize* repl form 'cps
+ (module-ref (resolve-interface '(language cps dump)) 'dump)))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index ad34a549d..be1b79e34 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2061,8 +2061,9 @@ should be .data or .rodata), and return the resulting linker object.
((array? obj)
(let-values
- ;; array tag + rank + contp flag: see libguile/arrays.h .
- (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
+ ;; array tag + rank
+ ;; see libguile/arrays.h: SCM_I_ARRAY_NDIM, SCM_I_ARRAYP, scm_i_raw_array
+ (((tag) (logior tc7-array (ash (array-rank obj) 17)))
((bv-set! bvs-set!)
(case word-size
((4) (values bytevector-u32-set! bytevector-s32-set!))
@@ -2284,7 +2285,7 @@ needed."
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0300)
-(define *bytecode-minor-version* 5)
+(define *bytecode-minor-version* 6)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index e9f17dae8..54840d8fd 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -73,7 +73,7 @@
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth values)
+ (define (return-handler frame depth)
(print-return frame depth width prefix max-indent))
(trap-calls-to-procedure proc apply-handler return-handler))