dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge.

Browse source
This commit is contained in:
Dale Mellor 2020-06-07 16:03:17 +01:00
commit ef8e4ade14
22 changed files with 576 additions and 343 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -6,6 +6,7 @@
(indent-tabs-mode . nil)))
(scheme-mode
. ((indent-tabs-mode . nil)
(eval . (put 'let/ec 'scheme-indent-function 1))
(eval . (put 'pass-if 'scheme-indent-function 1))
(eval . (put 'pass-if-exception 'scheme-indent-function 2))
(eval . (put 'pass-if-equal 'scheme-indent-function 2))

7
bootstrap/Makefile.am
View file

@ -22,12 +22,7 @@
GUILE_WARNINGS = -W0
# Loading eval.go happens before boot and therefore before modules are
# resolved. For some reason if compiled without resolve-primitives,
# attempts to resolve primitives at boot fail; weird. Should fix this
# but in the meantime we turn on primitive resolution (which normally
# only happens at -O2).
GUILE_OPTIMIZATIONS = -O1 -Oresolve-primitives -Ono-cps
GUILE_OPTIMIZATIONS = -O1
include $(top_srcdir)/am/bootstrap.am

4
doc/ref/api-control.texi
View file

@ -678,8 +678,8 @@ Evaluate @var{expr} in a prompt, optionally specifying a tag and a
handler. If no tag is given, the default prompt tag is used.
If no handler is given, a default handler is installed. The default
handler accepts a procedure of one argument, which will called on the
captured continuation, within a prompt.
handler accepts a procedure of one argument, which will be called on
the captured continuation, within a prompt.
Sometimes it's easier just to show code, as in this case:

12
doc/ref/api-modules.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2019
@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2019, 2020
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -295,17 +295,15 @@ example,
(set! foo (delete-duplicates ...)))
@end example
When a module is autoloaded, all its bindings become available.
@var{symbol-list} is just those that will first trigger the load.
When a module is autoloaded, only the bindings in @var{symbol-list}
become available@footnote{In Guile 2.2 and earlier, @emph{all} the
module bindings would become available; @var{symbol-list} was just the
list of bindings that will first trigger the load.}.
An autoload is a good way to put off loading a big module until it's
really needed, for instance for faster startup or if it will only be
needed in certain circumstances.
@code{@@} can do a similar thing (@pxref{Using Guile Modules}), but in
that case an @code{@@} form must be written every time a binding from
the module is used.
@item #:export @var{list}
@cindex export
Export all identifiers in @var{list} which must be a list of symbols

12
doc/ref/api-procedures.texi
View file

@ -143,9 +143,11 @@ loaded, and save the result to disk. Procedures can be compiled at
runtime as well. @xref{Read/Load/Eval/Compile}, for more information
on runtime compilation.
Compiled procedures, also known as @dfn{programs}, respond all
procedures that operate on procedures. In addition, there are a few
more accessors for low-level details on programs.
Compiled procedures, also known as @dfn{programs}, respond to all
procedures that operate on procedures: you can pass a program to
@code{procedure?}, @code{procedure-name}, and so on (@pxref{Procedure
Properties}). In addition, there are a few more accessors for low-level
details on programs.
Most people won't need to use the routines described in this section,
but it's good to have them documented. You'll have to include the
@ -728,8 +730,8 @@ Return @code{#t} if @var{obj} is a procedure.
@deffn {Scheme Procedure} thunk? obj
@deffnx {C Function} scm_thunk_p (obj)
Return @code{#t} if @var{obj} is a thunk---a procedure that does
not accept arguments.
Return @code{#t} if @var{obj} is a procedure that can be called with
zero arguments.
@end deffn
@cindex procedure properties

1
doc/ref/guile.texi
View file

@ -228,6 +228,7 @@ on that make up Guile's application programming interface (API), see
* Using Guile in Emacs:: Guile and Emacs.
* Using Guile Tools:: A guild of scheming wizards.
* Installing Site Packages:: Installing Scheme code.
* Distributing Guile Code:: Building and distributing your code.
@end menu
@include scheme-intro.texi

2
doc/ref/r6rs.texi
View file

@ -1173,7 +1173,7 @@ evaluates to @code{baz}.
@deffn {Scheme Procedure} raise obj
Equivalent to core Guile @code{(raise-exception @var{obj})}.
@xref{Raising and Handling Exceptions}. p(Unfortunately, @code{raise}
@xref{Raising and Handling Exceptions}. (Unfortunately, @code{raise}
is already bound to a different function in core Guile.
@xref{Signals}.)
@end deffn

26
doc/ref/scheme-using.texi
View file

@ -804,6 +804,32 @@ installed on your system in @code{/usr/}, then the extensions dir will
be @code{/usr/lib/guile/@value{EFFECTIVE-VERSION}/extensions}.
@node Distributing Guile Code
@section Distributing Guile Code
@cindex distribution, of Guile projects
There's a tool that doesn't come bundled with Guile and yet can be very
useful in your day to day experience with it. This tool is
@uref{https://gitlab.com/a-sassmannshausen/guile-hall, Hall}.
Hall helps you create, manage, and package your Guile projects through a
simple command-line interface. When you start a new project, Hall
creates a folder containing a scaffold of your new project. It contains
a directory for your tests, for your libraries, for your scripts and for
your documentation. This means you immediately know where to put the
files you are hacking on.
@cindex build system, for Guile code
In addition, the scaffold will include your basic ``Autotools'' setup,
so you don't have to take care of that yourself (@pxref{The GNU Build
System,,, autoconf, Autoconf: Creating Automatic Configuration Scripts},
for more information on the GNU ``Autotools''). Having Autotools set up
with your project means you can immediately start hacking on your
project without worrying about whether your code will work on other
people's computers. Hall can also generate package definitions for the
GNU@tie{}Guix package manager, making it easy for Guix users to install
it.
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:

2
doc/ref/sxml.texi
View file

@ -230,7 +230,7 @@ SAX parsers were created to give the programmer more control on the
parsing process. A programmer gives the SAX parser a number of
``callbacks'': functions that will be called on various features of the
XML stream as they are encountered. SAX parsers are more efficient, but
much harder to user, as users typically have to manually maintain a
much harder to use, as users typically have to manually maintain a
stack of open elements.
Kiselyov realized that the SAX programming model could be made much

6
doc/ref/vm.texi
View file

@ -1375,7 +1375,7 @@ as a @code{scm} value directly.
@deftypefn Instruction {} make-non-immediate s24:@var{dst} n32:@var{offset}
Load a pointer to statically allocated memory into @var{dst}. The
object's memory is will be found @var{offset} 32-bit words away from the
object's memory will be found @var{offset} 32-bit words away from the
current instruction pointer. Whether the object is mutable or immutable
depends on where it was allocated by the compiler, and loaded by the
loader.
@ -1384,7 +1384,7 @@ loader.
Sometimes you need to load up a code pointer into a register; for this,
use @code{load-label}.
@deftypefn Instruction {} make-non-immediate s24:@var{dst} l32:@var{offset}
@deftypefn Instruction {} load-label s24:@var{dst} l32:@var{offset}
Load a label @var{offset} words away from the current @code{ip} and
write it to @var{dst}. @var{offset} is a signed 32-bit integer.
@end deftypefn
@ -1422,7 +1422,7 @@ pointer. @var{offset} is a signed value.
Fields of non-immediates may need to be fixed up at load time, because
we do not know in advance at what address they will be loaded. This is
the case, for example, for a pair containing a non-immediate in one of
its fields. @code{static-ref} and @code{static-patch!} are used in
its fields. @code{static-set!} and @code{static-patch!} are used in
these situations.
@deftypefn Instruction {} static-set! s24:@var{src} lo32:@var{offset}

2
libguile/filesys.c
View file

@ -1762,7 +1762,7 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
SCM_SYSERROR;
SCM_RETURN_NEWSMOB2 (scm_tc16_dir | (SCM_DIR_FLAG_OPEN << 16),
ds, SCM_PACK_POINTER (mutex));
ds, SCM_UNPACK (SCM_PACK_POINTER (mutex)));
}
#undef FUNC_NAME

5
libguile/procs.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018
/* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018,2020
Free Software Foundation, Inc.
This file is part of Guile.
@ -58,7 +58,8 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a thunk.")
"Return @code{#t} if @var{obj} is a procedure that can be "
"called with zero arguments.")
#define FUNC_NAME s_scm_thunk_p
{
int req, opt, rest;

5
meta/guile.m4
View file

@ -60,7 +60,10 @@
# @code{AC_SUBST}.
#
AC_DEFUN([GUILE_PKG],
[PKG_PROG_PKG_CONFIG
[AC_REQUIRE([PKG_PROG_PKG_CONFIG])
if test "x$PKG_CONFIG" = x; then
AC_MSG_ERROR([pkg-config is missing, please install it])
fi
_guile_versions_to_search="m4_default([$1], [3.0 2.2 2.0])"
if test -n "$GUILE_EFFECTIVE_VERSION"; then
_guile_tmp=""

2
module/language/cps.scm
View file

@ -221,7 +221,7 @@
(make-$kclause (build-arity arity) kbody kalternate))))
(define-syntax build-term
(syntax-rules (unquote $rec $continue)
(syntax-rules (unquote $continue $branch $prompt $throw)
((_ (unquote exp))
exp)
((_ ($continue k src exp))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
;; Copyright (C) 2013-2020 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
@ -25,19 +25,21 @@
(define-module (language cps cse)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps effects-analysis)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps renumber)
#:export (eliminate-common-subexpressions))
(define (compute-available-expressions succs kfun effects)
(define (compute-available-expressions succs kfun clobbers)
"Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
an intset containing ancestor labels whose value is available at LABEL."
(let ((init (intmap-map (lambda (label succs) #f) succs))
(kill (compute-clobber-map effects))
(kill clobbers)
(gen (intmap-map (lambda (label succs) (intset label)) succs))
(subtract (lambda (in-1 kill-1)
(if in-1
@ -77,18 +79,18 @@ an intset containing ancestor labels whose value is available at LABEL."
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define-syntax-rule (true-idx idx) (ash idx 1))
(define-syntax-rule (false-idx idx) (1+ (ash idx 1)))
(define (compute-truthy-expressions conts kfun)
"Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each label in the function starting at KFUN..
be true and/or false at each label in the function starting at KFUN.
Returns an intmap of intsets. The even elements of the intset indicate
labels that may be true, and the odd ones indicate those that may be
false. It could be that both true and false proofs are available."
(define (true-idx label) (ash label 1))
(define (false-idx label) (1+ (ash label 1)))
(define (propagate boolv succ out)
(let* ((in (intmap-ref boolv succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(in* (if in (intset-union in out) out)))
(if (eq? in in*)
(values '() boolv)
(values (list succ)
@ -132,288 +134,503 @@ false. It could be that both true and false proofs are available."
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(intset-fold
(lambda (kfun boolv)
(worklist-fold* visit-cont
(intset kfun)
(intmap-add boolv kfun empty-intset)))
(intmap-keys (compute-reachable-functions conts kfun))
empty-intmap))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (intset-map f set)
(define-record-type <analysis>
(make-analysis effects clobbers preds avail truthy-labels)
analysis?
(effects analysis-effects)
(clobbers analysis-clobbers)
(preds analysis-preds)
(avail analysis-avail)
(truthy-labels analysis-truthy-labels))
;; When we determine that we can replace an expression with
;; already-bound variables, we change the expression to a $values. At
;; its continuation, if it turns out that the $values expression is the
;; only predecessor, we elide the predecessor, to make redundant branch
;; folding easier. Ideally, elision results in redundant branches
;; having multiple predecessors which already have values for the
;; branch.
;;
;; We could avoid elision, and instead search backwards when we get to a
;; branch that we'd like to elide. However it's gnarly: branch elisions
;; reconfigure the control-flow graph, and thus affect the avail /
;; truthy maps. If we forwarded such a distant predecessor, if there
;; were no intermediate definitions, we'd have to replay the flow
;; analysis from far away. Maybe it's possible but it's not obvious.
;;
;; The elision mechanism is to rewrite predecessors to continue to the
;; successor. We could have instead replaced the predecessor with the
;; body of the successor, but that would invalidate the values of the
;; avail / truthy maps, as well as the clobber sets.
;;
;; We can't always elide the predecessor though. If any of the
;; predecessor's predecessors is a back-edge, it hasn't been
;; residualized yet and so we can't rewrite it. This is an
;; implementation limitation.
;;
(define (forward-cont cont from to)
(define (rename k) (if (eqv? k from) to k))
(rewrite-cont cont
(($ $kargs names vals ($ $continue k src exp))
($kargs names vals ($continue (rename k) src ,exp)))
(($ $kargs names vals ($ $branch kf kt src op param args))
($kargs names vals ($branch (rename kf) (rename kt) src op param args)))
(($ $kargs names vals ($ $prompt k kh src escape? tag))
($kargs names vals ($prompt (rename k) (rename kh) src escape? tag)))
(($ $kreceive ($ $arity req () rest () #f) kbody)
($kreceive req rest (rename kbody)))
(($ $kclause arity kbody kalternate)
;; Can only be a body continuation.
($kclause ,arity (rename kbody) kalternate))))
(define (elide-predecessor label pred out analysis)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((pred-preds (intmap-ref preds pred)))
(and
;; Don't elide predecessors that are the targets of back-edges.
(< (intset-prev pred-preds) pred)
(cons
(intset-fold
(lambda (pred-pred out)
(define (rename k) (if (eqv? k pred) label k))
(intmap-replace!
out pred-pred
(forward-cont (intmap-ref out pred-pred) pred label)))
pred-preds
(intmap-remove out pred))
(make-analysis effects
clobbers
(intmap-add (intmap-add preds label pred intset-remove)
label pred-preds intset-union)
avail
truthy-labels)))))))
(define (prune-branch analysis pred succ)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(make-analysis effects
clobbers
(intmap-add preds succ pred intset-remove)
avail
truthy-labels))))
(define (forward-branch analysis pred old-succ new-succ)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(make-analysis effects
clobbers
(let ((preds (intmap-add preds old-succ pred
intset-remove)))
(intmap-add preds new-succ pred intset-add))
avail
truthy-labels))))
(define (prune-successors analysis pred succs)
(intset-fold (lambda (succ analysis)
(prune-branch analysis pred succ))
succs analysis))
(define (compute-avail-and-bool-edge analysis pred succ out)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((avail (intmap-ref avail pred))
(kill (intmap-ref clobbers pred))
(bool (intmap-ref truthy-labels pred)))
(values (intset-add (intset-subtract avail kill) pred)
(match (and (< pred succ) (intmap-ref out pred))
(($ $kargs _ _ ($ $branch kf kt))
(define (maybe-add bool k idx)
(if (eqv? k succ) (intset-add bool idx) bool))
(maybe-add (maybe-add bool kf (false-idx pred))
kt (true-idx pred)))
(_ bool)))))))
(define (propagate-analysis analysis label out)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(call-with-values
(lambda ()
(intset-fold
(lambda (pred avail-in bool-in)
(call-with-values
(lambda ()
(compute-avail-and-bool-edge analysis pred label out))
(lambda (avail-in* bool-in*)
(values (if avail-in
(intset-intersect avail-in avail-in*)
avail-in*)
(intset-union bool-in bool-in*)))))
(intmap-ref preds label) #f empty-intset))
(lambda (avail-in bool-in)
(make-analysis effects clobbers preds
(intmap-replace avail label avail-in)
(intmap-replace truthy-labels label bool-in)))))))
(define (term-successors term)
(match term
(($ $continue k) (intset k))
(($ $branch kf kt) (intset kf kt))
(($ $prompt k kh) (intset k kh))
(($ $throw) empty-intset)))
(define (intmap-select map keys)
(persistent-intmap
(intset-fold (lambda (i out) (intmap-add! out i (f i)))
set
empty-intmap)))
(intmap-fold (lambda (k v out)
(if (intset-ref keys k)
(intmap-add! out k v)
out))
map empty-intmap)))
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
;; defined by a given labelled expression.
(define (compute-defs conts kfun)
(intset-map (lambda (label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(if self (list self) '()))
(($ $kclause arity body alt)
(match (intmap-ref conts body)
(($ $kargs names vars) vars)))
(($ $kreceive arity kargs)
(match (intmap-ref conts kargs)
(($ $kargs names vars) vars)))
(($ $ktail)
'())
(($ $kargs names vars term)
(match term
(($ $continue k)
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))
(($ $branch)
'())
((or ($ $prompt) ($ $throw))
#f)))))
(compute-function-body conts kfun)))
(define (make-equivalent-expression-table)
;; Table associating expressions with equivalent variables, indexed by
;; the label that defines them.
(make-hash-table))
(define (add-equivalent-expression! table key label vars)
(let ((equiv (hash-ref table key empty-intmap)))
(define (allow-equal old new)
(if (equal? old new)
old
(error "bad equiv var update" label old new)))
(hash-set! table key
(intmap-add equiv label vars allow-equal))))
(define (lookup-equivalent-expressions table key avail)
(match (hash-ref table key)
(#f empty-intmap)
(equiv (intmap-select equiv avail))))
(define (compute-singly-referenced succs)
(define (visit label succs single multiple)
(intset-fold (lambda (label single multiple)
(if (intset-ref single label)
(values single (intset-add! multiple label))
(values (intset-add! single label) multiple)))
succs single multiple))
(call-with-values (lambda ()
(intmap-fold visit succs empty-intset empty-intset))
(lambda (single multiple)
(intset-subtract (persistent-intset single)
(persistent-intset multiple)))))
;; return #(taken not-taken), or #f if can't decide.
(define (fold-branch table key kf kt avail bool)
(let ((equiv (lookup-equivalent-expressions table key avail)))
(let lp ((candidate (intmap-prev equiv)))
(match candidate
(#f #f)
(_ (let ((t (intset-ref bool (true-idx candidate)))
(f (intset-ref bool (false-idx candidate))))
(if (eqv? t f)
(lp (intmap-prev equiv (1- candidate)))
(if t
(vector kt kf)
(vector kf kt)))))))))
(define (intmap-select map set)
(intset->intmap (lambda (label) (intmap-ref map label)) set))
(define (eliminate-common-subexpressions-in-fun kfun conts out substs)
(define equivalent-expressions (make-equivalent-expression-table))
(define (subst-var substs var)
(intmap-ref substs var (lambda (var) var)))
(define (subst-vars substs vars)
(let lp ((vars vars))
(match vars
(() '())
((var . vars) (cons (subst-var substs var) (lp vars))))))
(define (compute-equivalent-subexpressions conts kfun)
(define (visit-fun kfun body equiv-labels var-substs)
(let* ((conts (intmap-select conts body))
(effects (synthesize-definition-effects (compute-effects conts)))
(succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs))
(avail (compute-available-expressions succs kfun effects))
(defs (compute-defs conts kfun))
(equiv-set (make-hash-table)))
(define (subst-var var-substs var)
(intmap-ref var-substs var (lambda (var) var)))
(define (subst-vars var-substs vars)
(let lp ((vars vars))
(match vars
(() '())
((var . vars) (cons (subst-var var-substs var) (lp vars))))))
(define (compute-term-key var-substs term)
(match term
(($ $continue k src exp)
(match exp
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $const-fun label) #f)
(($ $code label) (cons 'code label))
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name param args)
(cons* name param (subst-vars var-substs args)))
(($ $values args) #f)))
(($ $branch kf kt src op param args)
(cons* op param (subst-vars var-substs args)))
((or ($ $prompt) ($ $throw)) #f)))
(define (add-auxiliary-definitions! label defs var-substs term-key)
(let ((defs (and defs (subst-vars var-substs defs))))
(define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key
(acons label (list var) equiv))))
(define-syntax add-definitions
(syntax-rules (<-)
((add-definitions)
#f)
((add-definitions
((def <- op arg ...) (aux <- op* arg* ...) ...)
. clauses)
(match term-key
(('op arg ...)
(match defs
(#f
;; If the successor is a control-flow join, don't
;; pretend to know the values of its defs.
#f)
((def) (add-def! (list 'op* arg* ...) aux) ...)))
(_ (add-definitions . clauses))))
((add-definitions
((op arg ...) (aux <- op* arg* ...) ...)
. clauses)
(match term-key
(('op arg ...)
(add-def! (list 'op* arg* ...) aux) ...)
(_ (add-definitions . clauses))))))
(add-definitions
((scm-set! p s i x) (x <- scm-ref p s i))
((scm-set!/tag p s x) (x <- scm-ref/tag p s))
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
((word-set! p s i x) (x <- word-ref p s i))
((word-set!/immediate p s x) (x <- word-ref/immediate p s))
((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s))
((u <- scm->f64 #f s) (s <- f64->scm #f u))
((s <- f64->scm #f u) (u <- scm->f64 #f s))
((u <- scm->u64 #f s) (s <- u64->scm #f u))
((s <- u64->scm #f u) (u <- scm->u64 #f s)
(u <- scm->u64/truncate #f s))
((s <- u64->scm/unlikely #f u) (u <- scm->u64 #f s)
(u <- scm->u64/truncate #f s))
((u <- scm->s64 #f s) (s <- s64->scm #f u))
((s <- s64->scm #f u) (u <- scm->s64 #f s))
((s <- s64->scm/unlikely #f u) (u <- scm->s64 #f s))
((u <- untag-fixnum #f s) (s <- s64->scm #f u)
(s <- tag-fixnum #f u))
;; NB: These definitions rely on U having top 2 bits equal to
;; 3rd (sign) bit.
((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
(u <- untag-fixnum #f s))
((s <- u64->s64 #f u) (u <- s64->u64 #f s))
((u <- s64->u64 #f s) (s <- u64->s64 #f u))
((u <- untag-char #f s) (s <- tag-char #f u))
((s <- tag-char #f u) (u <- untag-char #f s)))))
(define (visit-label label equiv-labels var-substs)
(define (term-defs term)
(match term
(($ $continue k)
(and (intset-ref singly-referenced k)
(intmap-ref defs label)))
(($ $branch) '())))
(match (intmap-ref conts label)
(($ $kargs names vars term)
(match (compute-term-key var-substs term)
(#f (values equiv-labels var-substs))
(term-key
(let* ((equiv (hash-ref equiv-set term-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs defs)
;; If this expression defines auxiliary definitions,
;; as `cons' does for the results of `car' and `cdr',
;; define those. Do so after finding equivalent
;; expressions, so that we can take advantage of
;; subst'd output vars.
(add-auxiliary-definitions! label defs var-substs term-key)
(values equiv-labels var-substs))
(let lp ((candidates equiv))
(match candidates
(()
;; No matching expressions. Add our expression
;; to the equivalence set, if appropriate. Note
;; that expressions that allocate a fresh object
;; or change the current fluid environment can't
;; be eliminated by CSE (though DCE might do it
;; if the value proves to be unused, in the
;; allocation case).
(let ((defs (term-defs term)))
(when (and defs
(not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid))))
(hash-set! equiv-set term-key (acons label defs equiv)))
(finish equiv-labels var-substs defs)))
(((and head (candidate . vars)) . candidates)
(cond
((not (intset-ref avail candidate))
;; This expression isn't available here; try
;; the next one.
(lp candidates))
(else
;; Yay, a match. Mark expression as equivalent. If
;; we provide the definitions for the successor, mark
;; the vars for substitution.
(let ((defs (term-defs term)))
(finish (intmap-add equiv-labels label head)
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
var-substs)
defs)))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will
;; visit definitions before uses first.
(fold2 visit-label
(compute-reverse-post-order succs kfun)
equiv-labels
var-substs)))
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)
empty-intmap
empty-intmap))
(define (apply-cse conts equiv-labels var-substs truthy-labels)
(define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1)))
(define (subst-var var)
(intmap-ref var-substs var (lambda (var) var)))
(define (visit-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun) ($ $code)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (and proc (subst-var proc)) ,(map subst-var args)))
(($ $primcall name param args)
($primcall name param ,(map subst-var args)))
(($ $values args)
($values ,(map subst-var args)))))
(define (visit-term label term)
(define (compute-branch-key branch)
(match branch
(($ $branch kf kt src op param args) (cons* op param args))))
(define (compute-expr-key expr)
(match expr
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $const-fun label) #f)
(($ $code label) (cons 'code label))
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name param args) (cons* name param args))
(($ $values args) #f)))
(define (compute-term-key term)
(match term
(($ $branch kf kt src op param args)
(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv) ; A branch defines no values.
(let* ((bool (intmap-ref truthy-labels label))
(t (intset-ref bool (true-idx equiv)))
(f (intset-ref bool (false-idx equiv))))
(if (eqv? t f)
(build-term
($branch kf kt src op param ,(map subst-var args)))
(build-term
($continue (if t kt kf) src ($values ()))))))
(#f
(build-term
($branch kf kt src op param ,(map subst-var args))))))
(($ $continue k src exp)
(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(build-term ($continue k src ($values vars))))
(#f
(build-term
($continue k src ,(visit-exp exp))))))
(($ $prompt k kh src escape? tag)
(build-term
($prompt k kh src escape? (subst-var tag))))
(($ $throw src op param args)
(build-term
($throw src op param ,(map subst-var args))))))
(($ $continue k src exp) (compute-expr-key exp))
(($ $branch) (compute-branch-key term))
(($ $prompt) #f)
(($ $throw) #f)))
(intmap-map
(lambda (label cont)
(rewrite-cont cont
(($ $kargs names vars term)
($kargs names vars ,(visit-term label term)))
(_ ,cont)))
conts))
(define (add-auxiliary-definitions! label defs substs term-key)
(define (add-def! aux-key var)
(add-equivalent-expression! equivalent-expressions aux-key label
(list var)))
(define-syntax add-definitions
(syntax-rules (<-)
((add-definitions)
#f)
((add-definitions
((def <- op arg ...) (aux <- op* arg* ...) ...)
. clauses)
(match term-key
(('op arg ...)
(match defs
(#f
;; If the successor is a control-flow join, don't
;; pretend to know the values of its defs.
#f)
((def) (add-def! (list 'op* arg* ...) aux) ...)))
(_ (add-definitions . clauses))))
((add-definitions
((op arg ...) (aux <- op* arg* ...) ...)
. clauses)
(match term-key
(('op arg ...)
(add-def! (list 'op* arg* ...) aux) ...)
(_ (add-definitions . clauses))))))
(add-definitions
((scm-set! p s i x) (x <- scm-ref p s i))
((scm-set!/tag p s x) (x <- scm-ref/tag p s))
((scm-set!/immediate p s x) (x <- scm-ref/immediate p s))
((word-set! p s i x) (x <- word-ref p s i))
((word-set!/immediate p s x) (x <- word-ref/immediate p s))
((pointer-set!/immediate p s x) (x <- pointer-ref/immediate p s))
((u <- scm->f64 #f s) (s <- f64->scm #f u))
((s <- f64->scm #f u) (u <- scm->f64 #f s))
((u <- scm->u64 #f s) (s <- u64->scm #f u))
((s <- u64->scm #f u) (u <- scm->u64 #f s)
(u <- scm->u64/truncate #f s))
((s <- u64->scm/unlikely #f u) (u <- scm->u64 #f s)
(u <- scm->u64/truncate #f s))
((u <- scm->s64 #f s) (s <- s64->scm #f u))
((s <- s64->scm #f u) (u <- scm->s64 #f s))
((s <- s64->scm/unlikely #f u) (u <- scm->s64 #f s))
((u <- untag-fixnum #f s) (s <- s64->scm #f u)
(s <- tag-fixnum #f u))
;; NB: These definitions rely on U having top 2 bits equal to
;; 3rd (sign) bit.
((s <- tag-fixnum #f u) (u <- scm->s64 #f s)
(u <- untag-fixnum #f s))
((s <- u64->s64 #f u) (u <- s64->u64 #f s))
((u <- s64->u64 #f s) (s <- u64->s64 #f u))
((u <- untag-char #f s) (s <- tag-char #f u))
((s <- tag-char #f u) (u <- untag-char #f s))))
(define (rename-uses term substs)
(define (subst-var var)
(intmap-ref substs var (lambda (var) var)))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $const-fun) ($ $code))
,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (and proc (subst-var proc)) ,(map subst-var args)))
(($ $primcall name param args)
($primcall name param ,(map subst-var args)))
(($ $values args)
($values ,(map subst-var args)))))
(rewrite-term term
(($ $branch kf kt src op param args)
($branch kf kt src op param ,(map subst-var args)))
(($ $continue k src exp)
($continue k src ,(rename-exp exp)))
(($ $prompt k kh src escape? tag)
($prompt k kh src escape? (subst-var tag)))
(($ $throw src op param args)
($throw src op param ,(map subst-var args)))))
(define (visit-exp label exp analysis)
(define (residualize) exp)
(define (forward vals) (build-exp ($values vals)))
(match (compute-expr-key exp)
(#f (residualize))
(key
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(match (lookup-equivalent-expressions equivalent-expressions
key (intmap-ref avail label))
((? (lambda (x) (eq? x empty-intmap)))
(residualize))
(equiv
(forward (intmap-ref equiv (intmap-next equiv))))))))))
(define (maybe-forward-branch-predecessor label pred key kf kt out analysis)
(cond
((<= label pred)
;; A backwards branch; punt.
(values out analysis))
(else
(call-with-values (lambda ()
(compute-avail-and-bool-edge analysis pred label out))
(lambda (pred-avail pred-bool)
(match (fold-branch equivalent-expressions key kf kt
pred-avail pred-bool)
(#(taken not-taken)
(values (intmap-replace!
out pred
(forward-cont (intmap-ref out pred) label taken))
(forward-branch analysis pred label taken)))
(#f
(values out analysis))))))))
(define (simplify-branch-predecessors label term out analysis)
;; if any predecessor's truthy-edge folds the branch, forward the
;; precedecessor. may cause branch to become dead, or cause
;; remaining predecessor to eliminate.
(match term
(($ $branch kf kt)
(let ((key (compute-branch-key term)))
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(call-with-values
(lambda ()
(intset-fold
(lambda (pred out analysis)
(maybe-forward-branch-predecessor label pred
key kf kt out analysis))
(intmap-ref preds label) out analysis))
(lambda (out* analysis*)
(if (eq? analysis analysis*)
#f
(cons out* analysis*))))))))))
(define (visit-branch label term analysis)
(match term
(($ $branch kf kt src)
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((key (compute-branch-key term))
(avail (intmap-ref avail label))
(bool (intmap-ref truthy-labels label)))
(match (fold-branch equivalent-expressions key kf kt avail bool)
(#(taken not-taken)
(values (build-term ($continue taken src ($values ())))
(prune-branch analysis label not-taken)))
(#f
(values term analysis)))))))))
(define (visit-term label names vars term out substs analysis)
(let ((term (rename-uses term substs))
(analysis (propagate-analysis analysis label out)))
(match term
(($ $branch)
;; Can only forward predecessors if this continuation binds no
;; values.
(match (and (null? vars)
(simplify-branch-predecessors label term out analysis))
(#f
(call-with-values (lambda ()
(visit-branch label term analysis))
(lambda (term analysis)
(values (intmap-add! out label
(build-cont ($kargs names vars ,term)))
substs
analysis))))
((out . analysis)
;; Recurse.
(visit-label label (build-cont ($kargs names vars ,term))
out substs analysis))))
(($ $continue k src exp)
(values (intmap-add! out label
(build-cont
($kargs names vars
($continue k src
,(visit-exp label exp analysis)))))
substs
analysis))
((or ($ $prompt) ($ $throw))
(values (intmap-add! out label (build-cont ($kargs names vars ,term)))
substs
analysis)))))
(define (visit-label label cont out substs analysis)
(match cont
(($ $kargs names vars term)
(define (visit-term-normally)
(visit-term label names vars term out substs analysis))
(match analysis
(($ <analysis> effects clobbers preds avail truthy-labels)
(let ((preds (intmap-ref preds label)))
(cond
((eq? preds empty-intset)
;; Branch folding made this term unreachable. Prune from
;; preds set.
(values out substs
(prune-successors analysis label (term-successors term))))
((trivial-intset preds)
=> (lambda (pred)
(match (intmap-ref out pred)
(($ $kargs names' vars' ($ $continue _ _ ($ $values vals)))
;; Substitute dominating definitions, and try to elide the
;; predecessor entirely.
(let ((substs (fold (lambda (var val substs)
(intmap-add substs var val))
substs vars vals)))
(match (elide-predecessor label pred out analysis)
(#f
;; Can't elide; predecessor must be target of
;; backwards branch.
(visit-term label names vars term out substs analysis))
((out . analysis)
(visit-term label names' vars' term out substs analysis)))))
(($ $kargs _ _ term)
(match (compute-term-key term)
(#f #f)
(term-key
(let ((fx (intmap-ref effects pred)))
;; Add residualized definition to the equivalence set.
;; Note that expressions that allocate a fresh object
;; or change the current fluid environment can't be
;; eliminated by CSE (though DCE might do it if the
;; value proves to be unused, in the allocation case).
(when (and (not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid))))
(add-equivalent-expression! equivalent-expressions term-key pred vars)))
;; If the predecessor defines auxiliary definitions, as
;; `cons' does for the results of `car' and `cdr', define
;; those as well.
(add-auxiliary-definitions! pred vars substs term-key)))
(visit-term-normally))
(_
(visit-term-normally)))))
(else
(visit-term-normally)))))))
(_ (values (intmap-add! out label cont) substs analysis))))
;; Because of the renumber pass, the labels are numbered in reverse
;; post-order, so the intmap-fold will visit definitions before
;; uses.
(let* ((effects (synthesize-definition-effects (compute-effects conts)))
(clobbers (compute-clobber-map effects))
(succs (compute-successors conts kfun))
(preds (invert-graph succs))
(avail (compute-available-expressions succs kfun clobbers))
(truthy-labels (compute-truthy-expressions conts kfun)))
(call-with-values
(lambda ()
(intmap-fold visit-label conts out substs
(make-analysis effects clobbers preds avail truthy-labels)))
(lambda (out substs analysis)
(values out substs)))))
(define (fold-renumbered-functions f conts . seeds)
;; Precondition: CONTS has been renumbered, and therefore functions
;; contained within it are topologically sorted, and the conts of each
;; function's body are numbered sequentially after the function's
;; $kfun.
(define (next-function-body kfun)
(match (intmap-ref conts kfun (lambda (_) #f))
(#f #f)
((and cont ($ $kfun))
(let lp ((k (1+ kfun)) (body (intmap-add! empty-intmap kfun cont)))
(match (intmap-ref conts k (lambda (_) #f))
((or #f ($ $kfun))
(persistent-intmap body))
(cont
(lp (1+ k) (intmap-add! body k cont))))))))
(let fold ((kfun 0) (seeds seeds))
(match (next-function-body kfun)
(#f (apply values seeds))
(conts
(call-with-values (lambda () (apply f kfun conts seeds))
(lambda seeds
(fold (1+ (intmap-prev conts)) seeds)))))))
(define (eliminate-common-subexpressions conts)
(call-with-values (lambda () (compute-equivalent-subexpressions conts 0))
(lambda (equiv-labels var-substs)
(let ((truthy-labels (compute-truthy-expressions conts 0)))
(apply-cse conts equiv-labels var-substs truthy-labels)))))
(let ((conts (renumber conts 0)))
(persistent-intmap
(fold-renumbered-functions eliminate-common-subexpressions-in-fun
conts empty-intmap empty-intmap))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015, 2017-2019 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015, 2017-2020 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
@ -82,7 +82,8 @@ member, or @code{#f} otherwise."
"Assuming the values of @var{map} are integers and are unique, compute
a map in which each value maps to its key. If the values are not
unique, an error will be signalled."
(intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
(persistent-intmap
(intmap-fold (lambda (k v out) (intmap-add! out v k)) map empty-intmap)))
(define (invert-partition map)
"Assuming the values of @var{map} are disjoint intsets, compute a map

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

@ -51,7 +51,7 @@
(verify exp)
(run-pass! (resolve exp env))
(run-pass! (expand exp))
(run-pass! (letrectify exp))
(run-pass! (letrectify exp #:seal-private-bindings? seal?))
(run-pass! (fix-letrec exp))
(run-pass! (peval exp env))
(run-pass! (eta-expand exp))

2
module/language/tree-il/spec.scm
View file

@ -42,7 +42,7 @@
(module-ref (resolve-interface `(language tree-il ,compiler)) compiler))
(if (match (memq #:cps? opts)
((_ cps? . _) cps?)
(#f (<= 1 optimization-level)))
(#f (<= 2 optimization-level)))
(cons 'cps (load-compiler 'compile-cps))
(cons 'bytecode (load-compiler 'compile-bytecode))))

10
module/statprof.scm
View file

@ -370,15 +370,6 @@ always collects full stacks.)"
(source-line-for-user source)
(source-column source)))
(define (program-debug-info-printable pdi)
(let* ((addr (program-debug-info-addr pdi))
(name (or (and=> (program-debug-info-name pdi) symbol->string)
(string-append "#x" (number->string addr 16))))
(loc (and=> (find-source-for-addr addr) source->string)))
(if loc
(string-append name " at " loc)
name)))
(define (addr->pdi addr cache)
(cond
((hashv-get-handle cache addr) => cdr)
@ -389,6 +380,7 @@ always collects full stacks.)"
(define (addr->printable addr pdi)
(or (and=> (and=> pdi program-debug-info-name) symbol->string)
(and=> (primitive-code-name addr) symbol->string)
(string-append "anon #x" (number->string addr 16))))
(define (inc-call-data-cum-sample-count! cd)

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

@ -27,16 +27,8 @@
(define* (available-optimizations #:optional lang-name)
(match lang-name
('tree-il
;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
;; will result in a lot of code that will never get optimized nicely.
;; Similarly letrectification is great for generated code quality, but
;; as it gives the compiler more to work with, it increases compile
;; time enough that we reserve it for -O2. Also, this makes -O1 avoid
;; assumptions about top-level values, in the same way that avoiding
;; resolve-primitives does.
'((#:cps? 1)
(#:resolve-primitives? 2)
'((#:cps? 2)
(#:resolve-primitives? 1)
(#:expand-primitives? 1)
(#:letrectify? 2)
(#:seal-private-bindings? 3)

6
module/web/client.scm
View file

@ -545,12 +545,14 @@ true)."
(define-syntax-rule (define-http-verb http-verb method doc)
(define* (http-verb uri #:key
(body #f)
(port (open-socket-for-uri uri))
(verify-certificate? #t)
(port (open-socket-for-uri uri
#:verify-certificate?
verify-certificate?))
(version '(1 . 1))
(keep-alive? #f)
(headers '())
(decode-body? #t)
(verify-certificate? #t)
(streaming? #f))
doc
(http-request uri

12
test-suite/tests/popen.test
View file

@ -221,10 +221,11 @@ exec 2>~a; read REPLY"
;;
(pass-if-equal "open-process"
'("hello world" 0)
'("HELLO WORLD" 0)
(receive (from to pid)
((@@ (ice-9 popen) open-process) OPEN_BOTH "rev")
(display "dlrow olleh" to) (close to)
((@@ (ice-9 popen) open-process) OPEN_BOTH
"tr" "[:lower:]" "[:upper:]")
(display "hello world" to) (close to)
(list (read-string from)
(status:exit-val (cdr (waitpid pid))))))
@ -244,8 +245,9 @@ exec 2>~a; read REPLY"
(status:exit-val (cdr (waitpid pid))))))
(pass-if-equal "pipeline"
'("hello world\n" (0 0))
'("HELLO WORLD\n" (0 0))
(receive (from to pids)
(pipeline '(("echo" "dlrow olleh") ("rev")))
(pipeline '(("echo" "hello world")
("tr" "[:lower:]" "[:upper:]")))
(list (read-string from)
(map (compose status:exit-val cdr waitpid) pids))))