mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 15:40:38 +02:00
Code Activity

Merge branch 'main' into compile-to-js-merge

Browse source
This commit is contained in:
Christine Lemmer-Webber 2021-10-10 20:59:04 -04:00
commit 204cb98646
No known key found for this signature in database
GPG key ID: 4BC025925FF8F4D3
370 changed files with 7622 additions and 4772 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/Makefile.am
View file

@ -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 \

16
module/ice-9/boot-9.scm
View file

@ -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

8
module/ice-9/ftw.scm
View file

@ -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)

69
module/ice-9/match.upstream.scm
View file

@ -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))))

1
module/ice-9/psyntax.scm
View file

@ -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))))))

7
module/ice-9/read.scm
View file

@ -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 #\\)

8
module/language/cps/cse.scm
View file

@ -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))

317
module/language/cps/dump.scm Normal file
View file

@ -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)))

81
module/language/cps/effects-analysis.scm
View file

@ -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)))

88
module/language/cps/graphs.scm
View file

@ -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)))))))

214
module/language/cps/slot-allocation.scm
View file

@ -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

2
module/language/cps/types.scm
View file

@ -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))))

174
module/language/cps/utils.scm
View file

@ -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))

6
module/language/tree-il/compile-bytecode.scm
View file

@ -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

11
module/language/tree-il/compile-cps.scm
View file

@ -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)))

869
module/language/tree-il/inlinable-exports.scm Normal file
View file

@ -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)))

20
module/language/tree-il/letrectify.scm
View file

@ -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)))

11
module/language/tree-il/optimize.scm
View file

@ -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)

192
module/language/tree-il/peval.scm
View file

@ -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))

3
module/language/tree-il/primitives.scm
View file

@ -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

282
module/language/tree-il/resolve-free-vars.scm Normal file
View file

@ -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))

49
module/scheme/base.scm
View file

@ -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))

4
module/srfi/srfi-1.scm
View file

@ -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)))

43
module/srfi/srfi-43.scm
View file

@ -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

7
module/system/base/optimize.scm
View file

@ -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)

2
module/system/foreign-library.scm
View file

@ -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")

17
module/system/repl/command.scm
View file

@ -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."

26
module/system/repl/common.scm
View file

@ -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))))

7
module/system/vm/assembler.scm
View file

@ -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},

2
module/system/vm/trace.scm
View file

@ -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))