[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-537-g812c83d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-537-g812c83d |
|
Date: |
Tue, 10 Dec 2013 19:07:30 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=812c83d48b38240d4c6c61c3ba89ea67a44efd42
The branch, master has been updated
via 812c83d48b38240d4c6c61c3ba89ea67a44efd42 (commit)
via 18e1113513467f319de09feae51e792548db9ecc (commit)
via a236867dc1e0bc0f486dcc72d3e7f20df67d316f (commit)
via 58b23156573ef66eb7bc5b9ec697786abc817fb5 (commit)
via 660f2775e90fb9d91d23cd86859fa8cbeac6a33a (commit)
via 7bbfc029592bf2c318a3101fce6fac06f0996d56 (commit)
via 67b5d06c1a4e0148496a03c269df46a0b61fea90 (commit)
via fa48a2f79aa623739b0d7d7046378964d6b72b9b (commit)
via d297e544d9138ef07597f0f4aae299209365c48c (commit)
from 67915ab079c806251232afe115c22444ee31d8af (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 812c83d48b38240d4c6c61c3ba89ea67a44efd42
Author: Andy Wingo <address@hidden>
Date: Tue Dec 10 20:03:59 2013 +0100
Fix section table writing for non-loadable sections
* module/system/vm/linker.scm (add-elf-objects): Don't fill in the
sh_addr field if the section is not loadable.
commit 18e1113513467f319de09feae51e792548db9ecc
Author: Andy Wingo <address@hidden>
Date: Tue Dec 10 19:53:55 2013 +0100
Quick documentation fixes.
* doc/ref/compiler.texi: Make it build.
commit a236867dc1e0bc0f486dcc72d3e7f20df67d316f
Author: Andy Wingo <address@hidden>
Date: Tue Dec 10 19:49:24 2013 +0100
Non-loadable sections should not have an sh_addr field set
* module/system/vm/linker.scm (relocate-section-header):
(write-linker-object): Sections that are not loadable should not have
their sh_addr fields set. Fix.
commit 58b23156573ef66eb7bc5b9ec697786abc817fb5
Author: Andy Wingo <address@hidden>
Date: Sat Dec 7 19:59:39 2013 +0100
Beginnings of CPS section in manual
* doc/ref/compiler.texi (Continuation-Passing Style): Beginnings of this
section. Will be finished when we fix implicit truncation.
commit 660f2775e90fb9d91d23cd86859fa8cbeac6a33a
Author: Andy Wingo <address@hidden>
Date: Sat Dec 7 19:58:43 2013 +0100
Fix cross-references in api-macros.texi
* doc/ref/api-macros.texi (Macro Expansion): Fix cross-references.
commit 7bbfc029592bf2c318a3101fce6fac06f0996d56
Author: Andy Wingo <address@hidden>
Date: Fri Dec 6 12:04:10 2013 +0100
Arities-fixing pass handles incoming $ktrunc with rest args
* module/language/cps/arities.scm (fix-clause-arities): Allow $ktrunc
arities with rest arguments.
commit 67b5d06c1a4e0148496a03c269df46a0b61fea90
Author: Andy Wingo <address@hidden>
Date: Fri Dec 6 11:39:04 2013 +0100
Elide values primcalls with continuations with rest arguments
* module/language/cps/elide-values.scm (elide-values): Elide values
primcalls when continuation has rest arguments.
commit fa48a2f79aa623739b0d7d7046378964d6b72b9b
Author: Andy Wingo <address@hidden>
Date: Fri Dec 6 11:08:45 2013 +0100
(call-with-values foo (lambda (a . b) a)) avoids consing rest list
* module/language/cps/slot-allocation.scm (allocate-slots): Don't
allocate slots to unused results of function calls. This can allow us
to avoid consing a rest list for call-with-values with an ignored rest
parameter, and can improve the parallel move code.
* module/language/cps/compile-bytecode.scm (compile-fun): Adapt to avoid
emitting bind-rest in values context if the rest arg is unused.
commit d297e544d9138ef07597f0f4aae299209365c48c
Author: Andy Wingo <address@hidden>
Date: Thu Dec 5 11:55:10 2013 +0100
compiler.texi tweaks
* doc/ref/compiler.texi (Compiler Tower): Reword a couple things.
(Tree-IL): Add more vertical space, for readability in info.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-macros.texi | 4 +-
doc/ref/compiler.texi | 266 ++++++++++++++++++++++++++++--
module/language/cps/arities.scm | 57 ++++---
module/language/cps/compile-bytecode.scm | 25 +++-
module/language/cps/elide-values.scm | 30 +++-
module/language/cps/slot-allocation.scm | 41 +++++
module/system/vm/linker.scm | 46 ++++--
7 files changed, 407 insertions(+), 62 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 6eb41c6..07fde8f 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -1139,8 +1139,8 @@ Scheme: it's Tree-IL, Guile's high-level intermediate
language.
@xref{Tree-IL}. As ``hygienic macros'' can produce identifiers that are
distinct but have the same name, the output format needs to be able to
represent distinctions between variable identities and names. Again,
-see @xref{Tree-IL} for all the details. The easiest thing is to just
-run @code{tree-il->scheme} on the result of macro-expansion:
address@hidden, for all the details. The easiest thing is to just run
address@hidden>scheme} on the result of macro-expansion:
@lisp
(macroexpand '(+ 1 2))
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 235e6c1..e826438 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -29,10 +29,10 @@ know how to compile your @code{.scm} file.
@node Compiler Tower
@subsection Compiler Tower
-Guile's compiler is quite simple, actually -- its @emph{compilers}, to
-put it more accurately. Guile defines a tower of languages, starting at
-Scheme and progressively simplifying down to languages that resemble the
-VM instruction set (@pxref{Instruction Set}).
+Guile's compiler is quite simple -- its @emph{compilers}, to put it more
+accurately. Guile defines a tower of languages, starting at Scheme and
+progressively simplifying down to languages that resemble the VM
+instruction set (@pxref{Instruction Set}).
Each language knows how to compile to the next, so each step is simple
and understandable. Furthermore, this set of languages is not hardcoded
@@ -135,11 +135,11 @@ fake language at the bottom of the tower:
@item Value
@end itemize
-Compiling to @code{value} loads the bytecode into a procedure, and wakes
-the sleeping giant.
+Compiling to @code{value} loads the bytecode into a procedure, turning
+cold bytes into warm code.
Perhaps this strangeness can be explained by example:
address@hidden defaults to compiling to object code, because it
address@hidden defaults to compiling to bytecode, because it
produces object code that has to live in the barren world outside the
Guile runtime; but @code{compile} defaults to compiling to @code{value},
as its product re-enters the Guile world.
@@ -302,10 +302,12 @@ take care of the rest.
An empty expression. In practice, equivalent to Scheme's @code{(if #f
#f)}.
@end deftp
+
@deftp {Scheme Variable} <const> src exp
@deftpx {External Representation} (const @var{exp})
A constant.
@end deftp
+
@deftp {Scheme Variable} <primitive-ref> src name
@deftpx {External Representation} (primitive @var{name})
A reference to a ``primitive''. A primitive is a procedure that, when
@@ -319,16 +321,19 @@ Compilation of Tree-IL usually begins with a pass that
resolves some
special cases for calls to certain primitives, like @code{apply} or
@code{cons}.
@end deftp
+
@deftp {Scheme Variable} <lexical-ref> src name gensym
@deftpx {External Representation} (lexical @var{name} @var{gensym})
A reference to a lexically-bound variable. The @var{name} is the
original name of the variable in the source program. @var{gensym} is a
unique identifier for this variable.
@end deftp
+
@deftp {Scheme Variable} <lexical-set> src name gensym exp
@deftpx {External Representation} (set! (lexical @var{name} @var{gensym})
@var{exp})
Sets a lexically-bound variable.
@end deftp
+
@deftp {Scheme Variable} <module-ref> src mod name public?
@deftpx {External Representation} (@@ @var{mod} @var{name})
@deftpx {External Representation} (@@@@ @var{mod} @var{name})
@@ -340,31 +345,38 @@ up in @var{mod}'s public interface, and serialized with
@code{@@};
otherwise it will be looked up among the module's private bindings,
and is serialized with @code{@@@@}.
@end deftp
+
@deftp {Scheme Variable} <module-set> src mod name public? exp
@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp})
@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp})
Sets a variable in a specific module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-ref> src name
@deftpx {External Representation} (toplevel @var{name})
References a variable from the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-set> src name exp
@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp})
Sets a variable in the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-define> src name exp
@deftpx {External Representation} (define (toplevel @var{name}) @var{exp})
Defines a new top-level variable in the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <conditional> src test then else
@deftpx {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional.
@end deftp
+
@deftp {Scheme Variable} <call> src proc args
@deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call.
@end deftp
+
@deftp {Scheme Variable} <primcall> src name args
@deftpx {External Representation} (primcall @var{name} . @var{args})
A call to a primitive. Equivalent to @code{(call (primitive @var{name})
@@ -374,12 +386,14 @@ analyze than @code{<call>}.
As part of the compilation process, instances of @code{(call (primitive
@var{name}) . @var{args})} are transformed into primcalls.
@end deftp
+
@deftp {Scheme Variable} <seq> src head tail
@deftpx {External Representation} (seq @var{head} @var{tail})
A sequence. The semantics is that @var{head} is evaluated first, and
any resulting values are ignored. Then @var{tail} is evaluated, in tail
position.
@end deftp
+
@deftp {Scheme Variable} <lambda> src meta body
@deftpx {External Representation} (lambda @var{meta} @var{body})
A closure. @var{meta} is an association list of properties for the
@@ -388,6 +402,7 @@ procedure. @var{body} is a single Tree-IL expression of
type
an alternate clause, this makes Tree-IL's @code{<lambda>} have the
expressiveness of Scheme's @code{case-lambda}.
@end deftp
+
@deftp {Scheme Variable} <lambda-case> req opt rest kw inits gensyms body
alternate
@deftpx {External Representation} @
(lambda-case ((@var{req} @var{opt} @var{rest} @var{kw} @var{inits}
@var{gensyms})@
@@ -421,6 +436,7 @@ position. Otherwise, if there is an @var{alternate}, it
should be a
If there is no @var{alternate}, a wrong-number-of-arguments error is
signaled.
@end deftp
+
@deftp {Scheme Variable} <let> src names gensyms vals exp
@deftpx {External Representation} (let @var{names} @var{gensyms} @var{vals}
@var{exp})
Lexical binding, like Scheme's @code{let}. @var{names} are the original
@@ -428,12 +444,14 @@ binding names, @var{gensyms} are gensyms corresponding to
the
@var{names}, and @var{vals} are Tree-IL expressions for the values.
@var{exp} is a single Tree-IL expression.
@end deftp
+
@deftp {Scheme Variable} <letrec> in-order? src names gensyms vals exp
@deftpx {External Representation} (letrec @var{names} @var{gensyms} @var{vals}
@var{exp})
@deftpx {External Representation} (letrec* @var{names} @var{gensyms}
@var{vals} @var{exp})
A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
@end deftp
+
@deftp {Scheme Variable} <prompt> escape-only? tag body handler
@deftpx {External Representation} (prompt @var{escape-only?} @var{tag}
@var{body} @var{handler})
A dynamic prompt. Instates a prompt named @var{tag}, an expression,
@@ -447,6 +465,7 @@ a single @code{<lambda-case>} body expression with no
optional or
keyword arguments, and no alternate, and whose first argument is
unreferenced. @xref{Prompts}, for more information.
@end deftp
+
@deftp {Scheme Variable} <abort> tag args tail
@deftpx {External Representation} (abort @var{tag} @var{args} @var{tail})
An abort to the nearest prompt with the name @var{tag}, an expression.
@@ -473,6 +492,7 @@ evaluating @code{exp} to the @code{lambda}-like bindings
described by
@code{<let-values>} is an optimization of a @code{<call>} to the
primitive, @code{call-with-values}.
@end deftp
+
@deftp {Scheme Variable} <fix> src names gensyms vals body
@deftpx {External Representation} (fix @var{names} @var{gensyms} @var{vals}
@var{body})
Like @code{<letrec>}, but only for @var{vals} that are unset
@@ -503,16 +523,236 @@ CPS language.
@subsection Continuation-Passing Style
@cindex CPS
-Continuation-passing style (CPS) is ...
+Continuation-passing style (CPS) is Guile's principal intermediate
+language, bridging the gap between languages for people and languages
+for machines. CPS gives a name to every part of a program: every
+control point, and every intermediate value. This makes it an excellent
+medium for reasoning about programs, which is the principal job of a
+compiler.
+
address@hidden
+* An Introduction to CPS::
+* CPS in Guile::
+* Compiling CPS::
address@hidden menu
+
address@hidden An Introduction to CPS
address@hidden An Introduction to CPS
+
+As an example, consider the following Scheme expression:
+
address@hidden
+(begin
+ (display "The sum of 32 and 10 is: ")
+ (display 42)
+ (newline))
address@hidden lisp
+
+Let us identify all of the sub-expressions in this expression. We give
+them unique labels, like @var{k1}, and annotate the original source
+code:
+
address@hidden
+(begin
+ (display "The sum of 32 and 10 is: ")
+ |k1 k2
+ k0
+ (display 42)
+ |k4 k5
+ k3
+ (newline))
+ |k7
+ k6
address@hidden lisp
+
+These labels also identify continuations. For example, the continuation
+of @code{k7} is @code{k6}. This is because after evaluating the value
+of @code{newline}, performed by the expression labelled @code{k7}, we
+continue to apply it in @var{k6}.
+
+Which label has @code{k0} as its continuation? It is either @code{k1}
+or @code{k2}. Scheme does not have a fixed order of evaluation of
+arguments, although it does guarantee that they are evaluated in some
+order. However, continuation-passing style makes evaluation order
+explicit. In Guile, this choice is made by the higher-level language
+compilers.
+
+Let us assume a left-to-right evaluation order. In that case the
+continuation of @code{k1} is @code{k2}, and the continuation of
address@hidden is @code{k0}.
+
+With this example established, we are ready to give an example of CPS in
+Scheme:
+
address@hidden
+(lambda (ktail)
+ (let ((k1 (lambda ()
+ (let ((k2 (lambda (proc)
+ (let ((k0 (lambda (arg0)
+ (proc k4 arg0))))
+ (k0 "The sum of 32 and 10 is: ")))))
+ (k2 display))))
+ (k4 (lambda _
+ (let ((k5 (lambda (proc)
+ (let ((k3 (lambda (arg0)
+ (proc k7 arg0))))
+ (k3 42)))))
+ (k5 display))))
+ (k7 (lambda _
+ (let ((k6 (lambda (proc)
+ (proc ktail))))
+ (k6 newline)))))
+ (k1))
address@hidden lisp
+
+Holy code explosion, Batman! What's with all the lambdas? Indeed, CPS
+is by nature much more verbose than ``direct-style'' intermediate
+languages like Tree-IL. At the same time, CPS is more simple than full
+Scheme, in the same way that a Turing machine is more simple than
+Scheme, although they are semantically equivalent.
+
+In the original program, the expression labelled @code{k0} is in effect
+context. Any values it returns are ignored. This is reflected in CPS
+by noting that its continuation, @code{k4}, takes any number of values
+and ignores them. Compare this to @code{k2}, which takes a single
+value; in this way we can say that @code{k1} is in a ``value'' context.
+Likewise @code{k6} is in tail context with respect to the expression as
+a whole, because its continuation is the tail continuation,
address@hidden CPS makes these details manifest, and gives them names.
+
address@hidden CPS in Guile
address@hidden CPS in Guile
+
+Like Tree-IL, CPS is also a structured language, implemented with
+records not S-expressions.
+
address@hidden {Scheme Variable} <prompt> escape-only? tag body handler
address@hidden {External Representation} (prompt @var{escape-only?} @var{tag}
@var{body} @var{handler})
address@hidden deftp
+
address@hidden {Scheme Variable} $arity req opt rest kw allow-other-keys?
address@hidden deftp
+
+
address@hidden {Scheme Variable} $letk conts body
address@hidden {External Representation} (letk @var{conts} @var{body})
address@hidden deftp
address@hidden {Scheme Variable} $continue k src exp
address@hidden {External Representation} (continue @var{k} @var{src} @var{exp})
address@hidden deftp
address@hidden {Scheme Variable} $letrec names syms funs body
address@hidden {External Representation} (letrec @var{names} @var{syms}
@var{funs} @var{body})
address@hidden deftp
+
+;; Continuations
address@hidden {Scheme Variable} $cont k cont
address@hidden {External Representation} (cont k cont)
address@hidden deftp
address@hidden {Scheme Variable} $kif kt kf
address@hidden {External Representation} (kif kt kf)
address@hidden deftp
address@hidden {Scheme Variable} $ktrunc arity k
address@hidden {External Representation} (ktrunc arity k)
address@hidden deftp
address@hidden {Scheme Variable} $kargs names syms body
address@hidden {External Representation} (kargs names syms body)
address@hidden deftp
address@hidden {Scheme Variable} $kentry self tail clauses
address@hidden {External Representation} (kentry self tail clauses)
address@hidden deftp
address@hidden {Scheme Variable} $ktail
address@hidden {External Representation} (ktail)
address@hidden deftp
address@hidden {Scheme Variable} $kclause arity cont
address@hidden {External Representation} (kclause arity cont)
address@hidden deftp
+
+;; Expressions.
address@hidden {Scheme Variable} $void
address@hidden {External Representation} (void)
address@hidden deftp
address@hidden {Scheme Variable} $const val
address@hidden {External Representation} (const val)
address@hidden deftp
address@hidden {Scheme Variable} $prim name
address@hidden {External Representation} (prim name)
address@hidden deftp
address@hidden {Scheme Variable} $fun src meta free body
address@hidden {External Representation} (fun src meta free body)
address@hidden deftp
address@hidden {Scheme Variable} $call proc args
address@hidden {External Representation} (call proc args)
address@hidden deftp
address@hidden {Scheme Variable} $primcall name args
address@hidden {External Representation} (primcall name args)
address@hidden deftp
address@hidden {Scheme Variable} $values args
address@hidden {External Representation} (values args)
address@hidden deftp
address@hidden {Scheme Variable} $prompt escape? tag handler pop
address@hidden {External Representation} (prompt escape? tag handler pop)
address@hidden deftp
+
+;; Helper.
+ $arity
+ make-$arity
+
+ ;; Terms.
+ $letk $continue $letrec
+
+ ;; Continuations.
+ $cont
+
+ ;; Continuation bodies.
+ $kif $ktrunc $kargs $kentry $ktail $kclause
+
+ ;; Expressions.
+ $void $const $prim $fun $call $primcall $values $prompt
+
+ ;; Building macros.
+ let-gensyms
+ build-cps-term build-cps-cont build-cps-exp
+ rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
+
+ ;; Misc.
+ parse-cps unparse-cps
+ fold-conts fold-local-conts
+
+cwcc
+
+records, unlike early cps (rabbit, orbit)
+
address@hidden Compiling CPS
address@hidden Compiling CPS
+
+In CPS, there are no nested expressions. Indeed, CPS even removes the
+concept of a stack. All applications in CPS are in tail context. For
+that reason, applications in CPS are jumps, not calls. The @code{(k1)}
+above is nothing more than a @code{goto}. @code{(k3 42)} is a
address@hidden with a value. In this way, CPS bridges the gap between the
+lambda calculus and machine instruction sequences.
+
+On the side of machine instructions, Guile does still have a stack, and
+the @code{lambda} forms shown above do not actually result in one
+closure being allocated per subexpression at run-time. Lambda
+expressions introduced by a CPS transformation can always be allocated
+as labels or basic blocks within a function. In fact, we make a
+syntactic distinction between closures and continuations in the CPS
+language, and attempt to transform closures to continuations (basic
+blocks) where possible, via the @dfn{contification} optimization pass.
+
+Values bound by continuations are allocated to stack slots in a
+function's frame. The compiler from CPS only allocates slots to values
+that are actually live; it's possible to have a value in scope but not
+allocated to a slot.
+
@node Bytecode
@subsection Bytecode
-Blah blah ...
-
address@hidden File Format}
address@hidden File Format}.
-(system vm loader)
+TODO: document (system vm loader)
@deffn {Scheme Variable} load-thunk-from-file file
@deffnx {C Function} scm_load_thunk_from_file (file)
@@ -524,7 +764,7 @@ created for use in UNIX systems. Guile has its own ELF
linker and
loader, so it uses the ELF format on all systems.
@end deffn
-likewise load-thunk-from-memory
+TODO: document load-thunk-from-memory
Compiling object code to the fake language, @code{value}, is performed
via loading objcode into a program, then executing that thunk with
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 8b98152..052208f 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -59,19 +59,26 @@
($continue kunspec src ($void)))))
($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
- ,(rewrite-cps-term arity
- (($ $arity () () #f () #f)
- ($continue kargs src ,exp))
+ ,(match arity
+ (($ $arity () () rest () #f)
+ (if rest
+ (let-gensyms (knil)
+ (build-cps-term
+ ($letk ((knil ($kargs () ()
+ ($continue kargs src ($const '())))))
+ ($continue knil src ,exp))))
+ (build-cps-term
+ ($continue kargs src ,exp))))
(_
- ,(let-gensyms (kvoid kvalues void)
- (build-cps-term
- ($letk* ((kvalues ($kargs ('void) (void)
- ($continue k src
- ($primcall 'values (void)))))
- (kvoid ($kargs () ()
- ($continue kvalues src
- ($void)))))
- ($continue kvoid src ,exp)))))))
+ (let-gensyms (kvoid kvalues void)
+ (build-cps-term
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($void)))))
+ ($continue kvoid src ,exp)))))))
(($ $kargs () () _)
($continue k src ,exp))
(_
@@ -93,16 +100,24 @@
($primcall 'return (v))))))
($continue k* src ,exp)))))))
(($ $ktrunc arity kargs)
- ,(rewrite-cps-term arity
- (($ $arity (_) () #f () #f)
- ($continue kargs src ,exp))
+ ,(match arity
+ (($ $arity (_) () rest () #f)
+ (if rest
+ (let-gensyms (kval val nil)
+ (build-cps-term
+ ($letk ((kval ($kargs ('val) (val)
+ ($letconst (('nil nil '()))
+ ($continue kargs src
+ ($values (val nil)))))))
+ ($continue kval src ,exp))))
+ (build-cps-term ($continue kargs src ,exp))))
(_
- ,(let-gensyms (kvalues value)
- (build-cps-term
- ($letk ((kvalues ($kargs ('value) (value)
- ($continue k src
- ($primcall 'values (value))))))
- ($continue kvalues src ,exp)))))))
+ (let-gensyms (kvalues value)
+ (build-cps-term
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
(($ $kargs () () _)
,(let-gensyms (k* drop)
(build-cps-term
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index aef2265..216fca6 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -201,7 +201,11 @@
(< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2)))))
(($ $ktrunc ($ $arity req () rest () #f) kargs)
- (compile-trunc label k exp (length req) (and rest #t) nlocals)
+ (compile-trunc label k exp (length req)
+ (and rest
+ (match (vector-ref contv (cfa-k-idx cfa kargs))
+ (($ $kargs names (_ ... rest)) rest)))
+ nlocals)
(unless (and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(eq? (cfa-k-sym cfa (+ n 2)) kargs))
@@ -260,7 +264,15 @@
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
- (emit-receive asm dst proc-slot nlocals)))
+ (cond
+ (dst
+ (emit-receive asm dst proc-slot nlocals))
+ (else
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an
+ ;; unused rest arg instead of implicitly.
+ (emit-receive-values asm proc-slot #t 1)
+ (emit-reset-frame asm nlocals)))))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
@@ -321,7 +333,10 @@
(emit-br asm k)
(emit-label asm receive-args)
(emit-receive-values asm proc-slot (->bool rest) nreq)
- (when rest
+ (when (and rest
+ (match (vector-ref contv (cfa-k-idx cfa
khandler-body))
+ (($ $kargs names (_ ... rest))
+ (maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
@@ -425,7 +440,7 @@
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
- (define (compile-trunc label k exp nreq rest? nlocals)
+ (define (compile-trunc label k exp nreq rest-var nlocals)
(match exp
(($ $call proc args)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
@@ -440,7 +455,7 @@
;; Express values truncation by the presence of an
;; unused rest arg instead of implicitly.
(emit-receive-values asm proc-slot #t nreq)
- (when rest?
+ (when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index 5835b2a..6069612 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -61,11 +61,33 @@
(($ $ktail)
($continue k src ($values vals)))
(($ $ktrunc ($ $arity req () rest () #f) kargs)
- ,(if (or rest (< (length vals) (length req)))
- term
- (let ((vals (list-head vals (length req))))
+ ,(cond
+ ((and (not rest) (= (length vals) (length req)))
+ (build-cps-term
+ ($continue kargs src ($values vals))))
+ ((and rest (>= (length vals) (length req)))
+ (let-gensyms (krest rest)
+ (let ((vals* (append (list-head vals (length req))
+ (list rest))))
(build-cps-term
- ($continue kargs src ($values vals))))))
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue kargs src
+ ($values vals*)))))
+ ,(let lp ((tail (list-tail vals (length req)))
+ (k krest))
+ (match tail
+ (()
+ (build-cps-term ($continue k src
+ ($const '()))))
+ ((v . tail)
+ (let-gensyms (krest rest)
+ (build-cps-term
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue k src
+ ($primcall 'cons
+ (v rest))))))
+ ,(lp tail krest))))))))))))
+ (else term)))
(($ $kargs args)
,(if (< (length vals) (length args))
term
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index ba83982..d1d02dd 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -354,6 +354,38 @@ are comparable with eqv?. A tmp slot may be used."
(_ #f))
(lp (1+ n)))))
+ ;; Results of function calls that are not used don't need to be
+ ;; allocated to slots.
+ (define (compute-unused-results!)
+ (define (ktrunc-get-kargs n)
+ (match (vector-ref contv n)
+ (($ $ktrunc arity kargs) (cfa-k-idx cfa kargs))
+ (_ #f)))
+ (let ((candidates (make-bitvector (vector-length contv) #f)))
+ ;; Find all $kargs that are the successors of $ktrunc nodes.
+ (let lp ((n 0))
+ (when (< n (vector-length contv))
+ (and=> (ktrunc-get-kargs n)
+ (lambda (kargs)
+ (bitvector-set! candidates kargs #t)))
+ (lp (1+ n))))
+ ;; For $kargs that only have $ktrunc predecessors, remove unused
+ ;; variables from the needs-slotv set.
+ (let lp ((n 0))
+ (let ((n (bit-position #t candidates n)))
+ (when n
+ (match (cfa-predecessors cfa n)
+ ;; At least one ktrunc is in the predecessor set, so we
+ ;; only need to do the check for nodes with >1
+ ;; predecessor.
+ ((or (_) ((? ktrunc-get-kargs) ...))
+ (for-each (lambda (var)
+ (when (dead-after-def? (cfa-k-sym cfa n) var dfa)
+ (bitvector-set! needs-slotv var #f)))
+ (vector-ref defv n)))
+ (_ #f))
+ (lp (1+ n)))))))
+
;; Compute the set of variables whose allocation should be delayed
;; until a "hint" is known about where to allocate them. This is
;; the case for some procedure arguments.
@@ -463,6 +495,10 @@ are comparable with eqv?. A tmp slot may be used."
(result-live (fold allocate!
post-live result-vars value-slots))
(result-slots (map (cut vector-ref slots <>) result-vars))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
(result-moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
@@ -513,6 +549,10 @@ are comparable with eqv?. A tmp slot may be used."
(result-live (fold allocate!
handler-live result-vars value-slots))
(result-slots (map (cut vector-ref slots <>) result-vars))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
(moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
@@ -599,6 +639,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-conts!)
(compute-constants!)
(compute-uses-and-defs!)
+ (compute-unused-results!)
(compute-needs-hint!)
(visit-entry)
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index 9a51778..5449e86 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -301,15 +301,18 @@ segment, the order of the linker objects is preserved."
(+ address
(modulo (- alignment (modulo address alignment)) alignment))))
-(define (relocate-section-header sec addr)
+(define (relocate-section-header sec offset)
"Return a new section header, just like @var{sec} but with its
address@hidden and @code{offset} set to @var{addr}."
address@hidden (and @code{addr} if it is loadable) set to @var{offset}."
(make-elf-section #:index (elf-section-index sec)
#:name (elf-section-name sec)
#:type (elf-section-type sec)
#:flags (elf-section-flags sec)
- #:addr addr
- #:offset addr
+ #:addr (if (zero? (logand SHF_ALLOC
+ (elf-section-flags sec)))
+ 0
+ offset)
+ #:offset offset
#:size (elf-section-size sec)
#:link (elf-section-link sec)
#:info (elf-section-info sec)
@@ -417,8 +420,11 @@ locations, as given in @var{symtab}."
(len (elf-section-size section))
(bytes (linker-object-bv o))
(relocs (linker-object-relocs o)))
- (unless (= offset (elf-section-addr section))
- (error "offset != addr" section))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ (unless (zero? (elf-section-addr section))
+ (error "non-loadable section has non-zero addr" section))
+ (unless (= offset (elf-section-addr section))
+ (error "loadable section has offset != addr" section)))
(if (not (= (elf-section-type section) SHT_NOBITS))
(begin
(if (not (= len (bytevector-length bytes)))
@@ -511,17 +517,23 @@ list of objects, augmented with objects for the special
ELF sections."
(write-elf-section-header bv offset endianness word-size section)
(if (= (elf-section-type section) SHT_NULL)
relocs
- (cons* (make-linker-reloc
- reloc-kind
- (+ offset (elf-section-header-addr-offset word-size))
- 0
- section-label)
- (make-linker-reloc
- reloc-kind
- (+ offset (elf-section-header-offset-offset word-size))
- 0
- section-label)
- relocs))))
+ (let ((relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-offset-offset word-size))
+ 0
+ section-label)
+ relocs)))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ relocs))))))
(let ((relocs (fold-values
(lambda (object relocs)
(write-and-reloc
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-537-g812c83d,
Andy Wingo <=