mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

Merge branch 'stable-2.2' into compile-to-js-2017

Browse source
This commit is contained in:
Ian Price 2017-06-14 16:52:48 +01:00
commit 1b36a76ea4
859 changed files with 56134 additions and 56340 deletions
Download patch file Download diff file Expand all files Collapse all files

625
module/Makefile.am
View file

@ -25,162 +25,148 @@ include $(top_srcdir)/am/guilec
# We're at the root of the module hierarchy.
modpath =
# Build eval.go first. Then build psyntax-pp.go, as the expander has to
# run on every loaded scheme file. It doesn't pay off at compile-time
# to interpret the expander in parallel.
BOOT_SOURCES = ice-9/psyntax-pp.scm
BOOT_GOBJECTS = $(BOOT_SOURCES:%.scm=%.go)
$(BOOT_GOBJECTS): ice-9/eval.go
$(GOBJECTS): $(BOOT_GOBJECTS)
CLEANFILES += ice-9/eval.go $(BOOT_GOBJECTS)
nobase_mod_DATA += ice-9/eval.scm $(BOOT_SOURCES)
nobase_ccache_DATA += ice-9/eval.go $(BOOT_GOBJECTS)
EXTRA_DIST += ice-9/eval.scm $(BOOT_SOURCES)
ETAGS_ARGS += ice-9/eval.scm $(BOOT_SOURCES)
VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go
$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
# We can compile these in any order, but it's fastest if we compile
# boot-9 first, then the compiler itself, then the rest of the code.
SOURCES = \
ice-9/boot-9.scm \
language/cps/intmap.scm \
language/cps/intset.scm \
language/tree-il/peval.scm \
system/vm/elf.scm \
ice-9/vlist.scm \
srfi/srfi-1.scm \
system/vm/linker.scm \
system/vm/dwarf.scm \
system/vm/assembler.scm \
\
language/tree-il.scm \
$(TREE_IL_LANG_SOURCES) \
$(CPS2_LANG_SOURCES) \
$(CPS_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
$(VALUE_LANG_SOURCES) \
$(SCHEME_LANG_SOURCES) \
$(SYSTEM_BASE_SOURCES) \
\
$(ICE_9_SOURCES) \
$(SYSTEM_SOURCES) \
$(SRFI_SOURCES) \
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
$(SCRIPTS_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(ELISP_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES) \
$(JS_IL_LANG_SOURCES) \
$(JS_LANG_SOURCES) \
$(LIB_SOURCES) \
$(WEB_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += \
ice-9/test.scm \
ice-9/compile-psyntax.scm \
ice-9/ChangeLog-2008
ETAGS_ARGS += \
ice-9/test.scm \
ice-9/compile-psyntax.scm \
ice-9/ChangeLog-2008
ice-9/psyntax-pp.scm.gen:
$(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
.PHONY: ice-9/psyntax-pp.scm.gen
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
$(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
$(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
$(top_builddir)/meta/build-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm"
SCHEME_LANG_SOURCES = \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-cps2.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
CPS_LANG_SOURCES = \
language/cps.scm \
language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
language/cps/compile-js.scm \
language/cps/constructors.scm \
language/cps/contification.scm \
language/cps/cse.scm \
language/cps/dce.scm \
language/cps/dfg.scm \
language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
language/cps/primitives.scm \
language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
language/cps/self-references.scm \
language/cps/slot-allocation.scm \
language/cps/simplify.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/type-fold.scm \
language/cps/types.scm \
language/cps/verify.scm
CPS2_LANG_SOURCES = \
language/cps2.scm \
language/cps2/cse.scm \
language/cps2/compile-cps.scm \
language/cps2/constructors.scm \
language/cps2/contification.scm \
language/cps2/dce.scm \
language/cps2/effects-analysis.scm \
language/cps2/elide-values.scm \
language/cps2/prune-bailouts.scm \
language/cps2/prune-top-level-scopes.scm \
language/cps2/renumber.scm \
language/cps2/optimize.scm \
language/cps2/simplify.scm \
language/cps2/self-references.scm \
language/cps2/spec.scm \
language/cps2/specialize-primcalls.scm \
language/cps2/split-rec.scm \
language/cps2/type-fold.scm \
language/cps2/types.scm \
language/cps2/utils.scm \
language/cps2/verify.scm \
language/cps2/with-cps.scm
BYTECODE_LANG_SOURCES = \
language/bytecode.scm \
language/bytecode/spec.scm
VALUE_LANG_SOURCES = \
language/value/spec.scm
ECMASCRIPT_LANG_SOURCES = \
SOURCES = \
ice-9/and-let-star.scm \
ice-9/atomic.scm \
ice-9/binary-ports.scm \
ice-9/boot-9.scm \
ice-9/buffered-input.scm \
ice-9/calling.scm \
ice-9/channel.scm \
ice-9/command-line.scm \
ice-9/common-list.scm \
ice-9/control.scm \
ice-9/curried-definitions.scm \
ice-9/debug.scm \
ice-9/deprecated.scm \
ice-9/documentation.scm \
ice-9/eval-string.scm \
ice-9/eval.scm \
ice-9/expect.scm \
ice-9/fdes-finalizers.scm \
ice-9/format.scm \
ice-9/ftw.scm \
ice-9/futures.scm \
ice-9/gap-buffer.scm \
ice-9/getopt-long.scm \
ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/history.scm \
ice-9/i18n.scm \
ice-9/iconv.scm \
ice-9/lineio.scm \
ice-9/list.scm \
ice-9/local-eval.scm \
ice-9/ls.scm \
ice-9/mapping.scm \
ice-9/match.scm \
ice-9/networking.scm \
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
ice-9/peg.scm \
ice-9/peg/cache.scm \
ice-9/peg/codegen.scm \
ice-9/peg/simplify-tree.scm \
ice-9/peg/string-peg.scm \
ice-9/peg/using-parsers.scm \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/popen.scm \
ice-9/ports.scm \
ice-9/posix.scm \
ice-9/pretty-print.scm \
ice-9/psyntax-pp.scm \
ice-9/q.scm \
ice-9/r5rs.scm \
ice-9/rdelim.scm \
ice-9/receive.scm \
ice-9/regex.scm \
ice-9/runq.scm \
ice-9/rw.scm \
ice-9/safe-r5rs.scm \
ice-9/safe.scm \
ice-9/sandbox.scm \
ice-9/save-stack.scm \
ice-9/scm-style-repl.scm \
ice-9/serialize.scm \
ice-9/session.scm \
ice-9/slib.scm \
ice-9/stack-catch.scm \
ice-9/streams.scm \
ice-9/string-fun.scm \
ice-9/suspendable-ports.scm \
ice-9/syncase.scm \
ice-9/textual-ports.scm \
ice-9/threads.scm \
ice-9/time.scm \
ice-9/top-repl.scm \
ice-9/unicode.scm \
ice-9/vlist.scm \
ice-9/weak-vector.scm \
\
language/brainfuck/parse.scm \
language/brainfuck/compile-scheme.scm \
language/brainfuck/compile-tree-il.scm \
language/brainfuck/spec.scm \
\
language/bytecode.scm \
language/bytecode/spec.scm \
\
language/cps.scm \
language/cps/closure-conversion.scm \
language/cps/compile-bytecode.scm \
language/cps/compile-js.scm \
language/cps/constructors.scm \
language/cps/contification.scm \
language/cps/cse.scm \
language/cps/dce.scm \
language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
language/cps/handle-interrupts.scm \
language/cps/intmap.scm \
language/cps/intset.scm \
language/cps/licm.scm \
language/cps/optimize.scm \
language/cps/peel-loops.scm \
language/cps/primitives.scm \
language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
language/cps/rotate-loops.scm \
language/cps/self-references.scm \
language/cps/simplify.scm \
language/cps/slot-allocation.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/specialize-numbers.scm \
language/cps/split-rec.scm \
language/cps/type-checks.scm \
language/cps/type-fold.scm \
language/cps/types.scm \
language/cps/utils.scm \
language/cps/verify.scm \
language/cps/with-cps.scm \
\
language/ecmascript/tokenize.scm \
language/ecmascript/parse.scm \
language/ecmascript/impl.scm \
@ -188,9 +174,8 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/function.scm \
language/ecmascript/array.scm \
language/ecmascript/compile-tree-il.scm \
language/ecmascript/spec.scm
ELISP_LANG_SOURCES = \
language/ecmascript/spec.scm \
\
language/elisp/falias.scm \
language/elisp/lexer.scm \
language/elisp/parser.scm \
@ -199,168 +184,35 @@ ELISP_LANG_SOURCES = \
language/elisp/runtime.scm \
language/elisp/runtime/function-slot.scm \
language/elisp/runtime/value-slot.scm \
language/elisp/spec.scm
BRAINFUCK_LANG_SOURCES = \
language/brainfuck/parse.scm \
language/brainfuck/compile-scheme.scm \
language/brainfuck/compile-tree-il.scm \
language/brainfuck/spec.scm
JS_IL_LANG_SOURCES = \
language/elisp/spec.scm \
\
language/javascript.scm \
language/javascript/simplify.scm \
language/javascript/spec.scm \
\
language/js-il.scm \
language/js-il/inlining.scm \
language/js-il/compile-javascript.scm \
language/js-il/spec.scm
JS_LANG_SOURCES = \
language/javascript.scm \
language/javascript/simplify.scm \
language/javascript/spec.scm
SCRIPTS_SOURCES = \
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
scripts/doc-snarf.scm \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/help.scm \
scripts/lint.scm \
scripts/list.scm \
scripts/punify.scm \
scripts/read-scheme-source.scm \
scripts/read-text-outline.scm \
scripts/use2dot.scm \
scripts/snarf-check-and-output-texi.scm \
scripts/summarize-guile-TODO.scm \
scripts/api-diff.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm \
scripts/autofrisk.scm \
scripts/scan-api.scm
SYSTEM_BASE_SOURCES = \
system/base/pmatch.scm \
system/base/syntax.scm \
system/base/compile.scm \
system/base/language.scm \
system/base/lalr.scm \
system/base/message.scm \
system/base/target.scm \
system/base/types.scm \
system/base/ck.scm
ICE_9_SOURCES = \
ice-9/r5rs.scm \
ice-9/deprecated.scm \
ice-9/and-let-star.scm \
ice-9/binary-ports.scm \
ice-9/calling.scm \
ice-9/command-line.scm \
ice-9/common-list.scm \
ice-9/control.scm \
ice-9/curried-definitions.scm \
ice-9/debug.scm \
ice-9/documentation.scm \
ice-9/eval-string.scm \
ice-9/expect.scm \
ice-9/format.scm \
ice-9/futures.scm \
ice-9/getopt-long.scm \
ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/i18n.scm \
ice-9/iconv.scm \
ice-9/lineio.scm \
ice-9/ls.scm \
ice-9/mapping.scm \
ice-9/match.scm \
ice-9/networking.scm \
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
ice-9/peg/simplify-tree.scm \
ice-9/peg/codegen.scm \
ice-9/peg/cache.scm \
ice-9/peg/using-parsers.scm \
ice-9/peg/string-peg.scm \
ice-9/peg.scm \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
ice-9/rdelim.scm \
ice-9/receive.scm \
ice-9/regex.scm \
ice-9/runq.scm \
ice-9/rw.scm \
ice-9/safe-r5rs.scm \
ice-9/safe.scm \
ice-9/save-stack.scm \
ice-9/scm-style-repl.scm \
ice-9/session.scm \
ice-9/slib.scm \
ice-9/stack-catch.scm \
ice-9/streams.scm \
ice-9/string-fun.scm \
ice-9/syncase.scm \
ice-9/threads.scm \
ice-9/top-repl.scm \
ice-9/buffered-input.scm \
ice-9/time.scm \
ice-9/history.scm \
ice-9/channel.scm \
ice-9/pretty-print.scm \
ice-9/ftw.scm \
ice-9/gap-buffer.scm \
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
ice-9/local-eval.scm \
ice-9/unicode.scm
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
SRFI_SOURCES = \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
srfi/srfi-4/gnu.scm \
srfi/srfi-6.scm \
srfi/srfi-8.scm \
srfi/srfi-9.scm \
srfi/srfi-9/gnu.scm \
srfi/srfi-10.scm \
srfi/srfi-11.scm \
srfi/srfi-13.scm \
srfi/srfi-14.scm \
srfi/srfi-16.scm \
srfi/srfi-17.scm \
srfi/srfi-18.scm \
srfi/srfi-19.scm \
srfi/srfi-26.scm \
srfi/srfi-27.scm \
srfi/srfi-28.scm \
srfi/srfi-31.scm \
srfi/srfi-34.scm \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-43.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \
srfi/srfi-69.scm \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm
RNRS_SOURCES = \
language/js-il/spec.scm \
\
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm \
language/scheme/spec.scm \
\
language/tree-il.scm \
language/tree-il/analyze.scm \
language/tree-il/canonicalize.scm \
language/tree-il/compile-cps.scm \
language/tree-il/debug.scm \
language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/peval.scm \
language/tree-il/primitives.scm \
language/tree-il/spec.scm \
\
language/value/spec.scm \
\
rnrs/base.scm \
rnrs/conditions.scm \
rnrs/control.scm \
@ -386,47 +238,120 @@ RNRS_SOURCES = \
rnrs/records/inspection.scm \
rnrs/records/procedural.scm \
rnrs/records/syntactic.scm \
rnrs.scm
EXTRA_DIST += scripts/ChangeLog-2008
EXTRA_DIST += scripts/README
OOP_SOURCES = \
oop/goops.scm \
oop/goops/active-slot.scm \
oop/goops/composite-slot.scm \
oop/goops/describe.scm \
oop/goops/internal.scm \
oop/goops/save.scm \
oop/goops/stklos.scm \
oop/goops/accessors.scm \
oop/goops/simple.scm
SYSTEM_SOURCES = \
system/vm/inspect.scm \
system/vm/coverage.scm \
system/vm/frame.scm \
system/vm/loader.scm \
system/vm/program.scm \
system/vm/trace.scm \
system/vm/traps.scm \
system/vm/trap-state.scm \
system/vm/debug.scm \
system/vm/disassembler.scm \
system/vm/vm.scm \
rnrs.scm \
\
oop/goops.scm \
oop/goops/active-slot.scm \
oop/goops/composite-slot.scm \
oop/goops/describe.scm \
oop/goops/internal.scm \
oop/goops/save.scm \
oop/goops/stklos.scm \
oop/goops/accessors.scm \
oop/goops/simple.scm \
\
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
scripts/doc-snarf.scm \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/help.scm \
scripts/lint.scm \
scripts/list.scm \
scripts/punify.scm \
scripts/read-scheme-source.scm \
scripts/read-text-outline.scm \
scripts/use2dot.scm \
scripts/snarf-check-and-output-texi.scm \
scripts/summarize-guile-TODO.scm \
scripts/api-diff.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm \
scripts/autofrisk.scm \
scripts/scan-api.scm \
\
srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
srfi/srfi-4/gnu.scm \
srfi/srfi-6.scm \
srfi/srfi-8.scm \
srfi/srfi-9.scm \
srfi/srfi-9/gnu.scm \
srfi/srfi-10.scm \
srfi/srfi-11.scm \
srfi/srfi-13.scm \
srfi/srfi-14.scm \
srfi/srfi-16.scm \
srfi/srfi-17.scm \
srfi/srfi-18.scm \
srfi/srfi-19.scm \
srfi/srfi-26.scm \
srfi/srfi-27.scm \
srfi/srfi-28.scm \
srfi/srfi-31.scm \
srfi/srfi-34.scm \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
srfi/srfi-41.scm \
srfi/srfi-42.scm \
srfi/srfi-43.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \
srfi/srfi-69.scm \
srfi/srfi-88.scm \
srfi/srfi-98.scm \
srfi/srfi-111.scm \
\
statprof.scm \
\
system/base/pmatch.scm \
system/base/syntax.scm \
system/base/compile.scm \
system/base/language.scm \
system/base/lalr.scm \
system/base/message.scm \
system/base/target.scm \
system/base/types.scm \
system/base/ck.scm \
\
system/foreign.scm \
\
system/foreign-object.scm \
system/xref.scm \
\
system/repl/debug.scm \
system/repl/error-handling.scm \
system/repl/common.scm \
system/repl/command.scm \
system/repl/repl.scm \
system/repl/server.scm \
system/repl/coop-server.scm
LIB_SOURCES = \
statprof.scm \
system/repl/coop-server.scm \
\
system/vm/assembler.scm \
system/vm/coverage.scm \
system/vm/debug.scm \
system/vm/disassembler.scm \
system/vm/dwarf.scm \
system/vm/elf.scm \
system/vm/frame.scm \
system/vm/inspect.scm \
system/vm/linker.scm \
system/vm/loader.scm \
system/vm/program.scm \
system/vm/trace.scm \
system/vm/trap-state.scm \
system/vm/traps.scm \
system/vm/vm.scm \
\
system/syntax.scm \
\
system/xref.scm \
\
sxml/apply-templates.scm \
sxml/fold.scm \
sxml/match.scm \
@ -435,6 +360,7 @@ LIB_SOURCES = \
sxml/ssax.scm \
sxml/transform.scm \
sxml/xpath.scm \
\
texinfo.scm \
texinfo/docbook.scm \
texinfo/html.scm \
@ -442,9 +368,8 @@ LIB_SOURCES = \
texinfo/string-utils.scm \
texinfo/plain-text.scm \
texinfo/reflection.scm \
texinfo/serialize.scm
WEB_SOURCES = \
texinfo/serialize.scm \
\
web/client.scm \
web/http.scm \
web/request.scm \
@ -453,10 +378,8 @@ WEB_SOURCES = \
web/server/http.scm \
web/uri.scm
EXTRA_DIST += oop/ChangeLog-2008
ELISP_SOURCES = \
language/elisp/boot.el
language/elisp/boot.el
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
@ -474,3 +397,21 @@ NOCOMP_SOURCES = \
sxml/upstream/SXPath-old.scm \
sxml/upstream/assert.scm \
sxml/upstream/input-parse.scm
## ice-9/test.scm is not currently installed.
EXTRA_DIST += \
ice-9/test.scm \
ice-9/compile-psyntax.scm \
ice-9/ChangeLog-2008 \
scripts/ChangeLog-2008 \
scripts/README \
oop/ChangeLog-2008
ETAGS_ARGS += \
ice-9/test.scm \
ice-9/compile-psyntax.scm
ice-9/psyntax-pp.scm.gen:
$(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
.PHONY: ice-9/psyntax-pp.scm.gen

52
module/ice-9/and-let-star.scm
View file

@ -1,6 +1,7 @@
;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013,
;;;; 2015 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,20 +23,45 @@
(define-syntax %and-let*
(lambda (form)
(syntax-case form ()
((_ orig-form ())
#'#t)
((_ orig-form () body bodies ...)
#'(begin body bodies ...))
((_ orig-form ((var exp) c ...) body ...)
;; Handle zero-clauses special-case.
((_ orig-form () . body)
#'(begin #t . body))
;; Reduce clauses down to one regardless of body.
((_ orig-form ((var expr) rest . rest*) . body)
(identifier? #'var)
#'(let ((var exp))
(and var (%and-let* orig-form (c ...) body ...))))
((_ orig-form ((exp) c ...) body ...)
#'(and exp (%and-let* orig-form (c ...) body ...)))
((_ orig-form (var c ...) body ...)
#'(let ((var expr))
(and var (%and-let* orig-form (rest . rest*) . body))))
((_ orig-form ((expr) rest . rest*) . body)
#'(and expr (%and-let* orig-form (rest . rest*) . body)))
((_ orig-form (var rest . rest*) . body)
(identifier? #'var)
#'(and var (%and-let* orig-form (c ...) body ...)))
((_ orig-form (bad-clause c ...) body ...)
#'(and var (%and-let* orig-form (rest . rest*) . body)))
;; Handle 1-clause cases without a body.
((_ orig-form ((var expr)))
(identifier? #'var)
#'expr)
((_ orig-form ((expr)))
#'expr)
((_ orig-form (var))
(identifier? #'var)
#'var)
;; Handle 1-clause cases with a body.
((_ orig-form ((var expr)) . body)
(identifier? #'var)
#'(let ((var expr))
(and var (begin . body))))
((_ orig-form ((expr)) . body)
#'(and expr (begin . body)))
((_ orig-form (var) . body)
(identifier? #'var)
#'(and var (begin . body)))
;; Handle bad clauses.
((_ orig-form (bad-clause . rest) . body)
(syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
(define-syntax and-let*

38
module/ice-9/atomic.scm Normal file
View file

@ -0,0 +1,38 @@
;; Atomic operations
;;;; Copyright (C) 2016 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
;;;;
(define-module (ice-9 atomic)
#:use-module ((language tree-il primitives)
:select (add-interesting-primitive!))
#:export (make-atomic-box
atomic-box?
atomic-box-ref
atomic-box-set!
atomic-box-swap!
atomic-box-compare-and-swap!))
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_atomic")
(add-interesting-primitive! 'make-atomic-box)
(add-interesting-primitive! 'atomic-box?)
(add-interesting-primitive! 'atomic-box-ref)
(add-interesting-primitive! 'atomic-box-set!)
(add-interesting-primitive! 'atomic-box-swap!)
(add-interesting-primitive! 'atomic-box-compare-and-swap!))

3
module/ice-9/binary-ports.scm
View file

@ -42,7 +42,8 @@
put-bytevector
unget-bytevector
open-bytevector-output-port
make-custom-binary-output-port))
make-custom-binary-output-port
make-custom-binary-input/output-port))
;; Note that this extension also defines %make-transcoded-port, which is
;; not exported but is used by (rnrs io ports).

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

File diff suppressed because it is too large Load diff

4
module/ice-9/command-line.scm
View file

@ -1,6 +1,6 @@
;;; Parsing Guile's command-line
;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc.
;;; Copyright (C) 1994-1998, 2000-2017 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
@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
(define* (version-etc package version #:key
(port (current-output-port))
;; FIXME: authors
(copyright-year 2014)
(copyright-year 2017)
(copyright-holder "Free Software Foundation, Inc.")
(copyright (format #f "Copyright (C) ~a ~a"
copyright-year copyright-holder))

136
module/ice-9/compile-psyntax.scm
View file

@ -20,67 +20,132 @@
(language tree-il primitives)
(language tree-il canonicalize)
(srfi srfi-1)
(ice-9 control)
(ice-9 pretty-print)
(system syntax))
(system syntax internal))
;; Minimize a syntax-object such that it can no longer be used as the
;; first argument to 'datum->syntax', but is otherwise equivalent.
(define (squeeze-syntax-object! syn)
(define (squeeze-syntax-object syn)
(define (ensure-list x) (if (vector? x) (vector->list x) x))
(let ((x (vector-ref syn 1))
(wrap (vector-ref syn 2))
(mod (vector-ref syn 3)))
(let ((x (syntax-expression syn))
(wrap (syntax-wrap syn))
(mod (syntax-module syn)))
(let ((marks (car wrap))
(subst (cdr wrap)))
(define (set-wrap! marks subst)
(vector-set! syn 2 (cons marks subst)))
(define (squeeze-wrap marks subst)
(make-syntax x (cons marks subst) mod))
(cond
((symbol? x)
(let loop ((marks marks) (subst subst))
(cond
((null? subst) (set-wrap! marks subst) syn)
((null? subst) (squeeze-wrap marks subst))
((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
((find (lambda (entry) (and (eq? x (car entry))
(equal? marks (cadr entry))))
(apply map list (map ensure-list
(cdr (vector->list (car subst))))))
=> (lambda (entry)
(set-wrap! marks
(list (list->vector
(cons 'ribcage
(map vector entry)))))
syn))
(squeeze-wrap marks
(list (list->vector
(cons 'ribcage
(map vector entry)))))))
(else (loop marks (cdr subst))))))
((or (pair? x) (vector? x))
syn)
((or (pair? x) (vector? x)) syn)
(else x)))))
(define (squeeze-constant! x)
(define (syntax-object? x)
(and (vector? x)
(= 4 (vector-length x))
(eq? 'syntax-object (vector-ref x 0))))
(cond ((syntax-object? x)
(squeeze-syntax-object! x))
(define (squeeze-constant x)
(cond ((syntax? x) (squeeze-syntax-object x))
((pair? x)
(set-car! x (squeeze-constant! (car x)))
(set-cdr! x (squeeze-constant! (cdr x)))
x)
(cons (squeeze-constant (car x))
(squeeze-constant (cdr x))))
((vector? x)
(for-each (lambda (i)
(vector-set! x i (squeeze-constant! (vector-ref x i))))
(iota (vector-length x)))
x)
(list->vector (squeeze-constant (vector->list x))))
(else x)))
(define (squeeze-tree-il x)
(post-order (lambda (x)
(if (const? x)
(make-const (const-src x)
(squeeze-constant! (const-exp x)))
(squeeze-constant (const-exp x)))
x))
x))
(define (translate-literal-syntax-objects x)
(define (find-make-syntax-lexical-binding x)
(let/ec return
(pre-order (lambda (x)
(when (let? x)
(for-each (lambda (name sym)
(when (eq? name 'make-syntax)
(return sym)))
(let-names x) (let-gensyms x)))
x)
x)
#f))
(let ((make-syntax-gensym (find-make-syntax-lexical-binding x))
(retry-tag (make-prompt-tag)))
(define (translate-constant x)
(let ((src (const-src x))
(exp (const-exp x)))
(cond
((list? exp)
(let ((exp (map (lambda (x)
(translate-constant (make-const src x)))
exp)))
(if (and-map const? exp)
x
(make-primcall src 'list exp))))
((pair? exp)
(let ((car (translate-constant (make-const src (car exp))))
(cdr (translate-constant (make-const src (cdr exp)))))
(if (and (const? car) (const? cdr))
x
(make-primcall src 'cons (list car cdr)))))
((vector? exp)
(let ((exp (map (lambda (x)
(translate-constant (make-const src x)))
(vector->list exp))))
(if (and-map const? exp)
x
(make-primcall src 'vector exp))))
((syntax? exp)
(make-call src
(if make-syntax-gensym
(make-lexical-ref src 'make-syntax
make-syntax-gensym)
(abort-to-prompt retry-tag))
(list
(translate-constant
(make-const src (syntax-expression exp)))
(translate-constant
(make-const src (syntax-wrap exp)))
(translate-constant
(make-const src (syntax-module exp))))))
(else x))))
(call-with-prompt retry-tag
(lambda ()
(post-order (lambda (x)
(if (const? x)
(translate-constant x)
x))
x))
(lambda (k)
;; OK, we have a syntax object embedded in this code, but
;; make-syntax isn't lexically bound. This is the case for the
;; top-level macro definitions in psyntax that follow the main
;; let blob. Attach a lexical binding and retry.
(unless (toplevel-define? x) (error "unexpected"))
(translate-literal-syntax-objects
(make-toplevel-define
(toplevel-define-src x)
(toplevel-define-name x)
(make-let (toplevel-define-src x)
(list 'make-syntax)
(list (module-gensym))
(list (make-toplevel-ref #f 'make-syntax))
(toplevel-define-exp x))))))))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(set! syntax-session-id (lambda () "*"))
@ -99,11 +164,12 @@
(close-port in))
(begin
(pretty-print (tree-il->scheme
(squeeze-tree-il
(canonicalize
(resolve-primitives
(macroexpand x 'c '(compile load eval))
(current-module))))
(translate-literal-syntax-objects
(squeeze-tree-il
(canonicalize
(resolve-primitives
(macroexpand x 'c '(compile load eval))
(current-module)))))
(current-module)
(list #:avoid-lambda? #f
#:use-case? #f

6
module/ice-9/control.scm
View file

@ -23,7 +23,11 @@
default-prompt-tag make-prompt-tag)
#:export (% abort shift reset shift* reset*
call-with-escape-continuation call/ec
let-escape-continuation let/ec))
let-escape-continuation let/ec
suspendable-continuation?))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_control")
(define (abort . args)
(apply abort-to-prompt (default-prompt-tag) args))

76
module/ice-9/deprecated.scm
View file

@ -16,4 +16,78 @@
;;;;
(define-module (ice-9 deprecated)
#:export ())
#:use-module ((ice-9 threads) #:prefix threads:))
(define-syntax-rule (define-deprecated var msg exp)
(begin
(define-syntax var
(lambda (x)
(issue-deprecation-warning msg)
(syntax-case x ()
((id arg (... ...)) #'(let ((x id)) (x arg (... ...))))
(id (identifier? #'id) #'exp))))
(export var)))
(define-deprecated _IONBF
"`_IONBF' is deprecated. Use the symbol 'none instead."
'none)
(define-deprecated _IOLBF
"`_IOLBF' is deprecated. Use the symbol 'line instead."
'line)
(define-deprecated _IOFBF
"`_IOFBF' is deprecated. Use the symbol 'block instead."
'block)
(define-syntax define-deprecated/threads
(lambda (stx)
(define (threads-name id)
(datum->syntax id (symbol-append 'threads: (syntax->datum id))))
(syntax-case stx ()
((_ name)
(with-syntax ((name* (threads-name #'name))
(warning (string-append
"Import (ice-9 threads) to have access to `"
(symbol->string (syntax->datum #'name)) "'.")))
#'(define-deprecated name warning name*))))))
(define-syntax-rule (define-deprecated/threads* name ...)
(begin (define-deprecated/threads name) ...))
(define-deprecated/threads*
call-with-new-thread
yield
cancel-thread
join-thread
thread?
make-mutex
make-recursive-mutex
lock-mutex
try-mutex
unlock-mutex
mutex?
mutex-owner
mutex-level
mutex-locked?
make-condition-variable
wait-condition-variable
signal-condition-variable
broadcast-condition-variable
condition-variable?
current-thread
all-threads
thread-exited?
total-processor-count
current-processor-count)
(define-public make-dynamic-state
(case-lambda
(()
(issue-deprecation-warning
"`(make-dynamic-state)' is deprecated; use `(current-dynamic-state)'
instead.")
(current-dynamic-state))
((parent)
(issue-deprecation-warning
"`(make-dynamic-state PARENT)' is deprecated; now that reified
dynamic state objects are themselves copies, just use PARENT directly.")
parent)))

58
module/ice-9/eval.scm
View file

@ -119,8 +119,11 @@
(proc arg ...))))
(define (compile-lexical-ref depth width)
(lambda (env)
(env-ref env depth width)))
(case depth
((0) (lambda (env) (env-ref env 0 width)))
((1) (lambda (env) (env-ref env 1 width)))
((2) (lambda (env) (env-ref env 2 width)))
(else (lambda (env) (env-ref env depth width)))))
(define (primitive=? name loc module var)
"Return true if VAR is the same as the primitive bound to NAME."
@ -495,27 +498,38 @@
(define (bind-kw args)
(let lp ((args args))
(cond
((and (pair? args) (pair? (cdr args))
(keyword? (car args)))
(let ((kw-pair (assq (car args) keywords))
(v (cadr args)))
(if kw-pair
;; Found a known keyword; set its value.
(env-set! env 0 (cdr kw-pair) v)
;; Unknown keyword.
(if (not allow-other-keys?)
((scm-error
'keyword-argument-error
"eval" "Unrecognized keyword"
'() (list (car args))))))
(lp (cddr args))))
((pair? args)
(if rest?
;; Be lenient parsing rest args.
(lp (cdr args))
((scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() (list (car args))))))
(cond
((keyword? (car args))
(let ((k (car args))
(args (cdr args)))
(cond
((assq k keywords)
=> (lambda (kw-pair)
;; Found a known keyword; set its value.
(if (pair? args)
(let ((v (car args))
(args (cdr args)))
(env-set! env 0 (cdr kw-pair) v)
(lp args))
((scm-error 'keyword-argument-error
"eval"
"Keyword argument has no value"
'() (list k))))))
;; Otherwise unknown keyword.
(allow-other-keys?
(lp (if (pair? args) (cdr args) args)))
(else
((scm-error 'keyword-argument-error
"eval" "Unrecognized keyword"
'() (list k)))))))
(rest?
;; Be lenient parsing rest args.
(lp (cdr args)))
(else
((scm-error 'keyword-argument-error
"eval" "Invalid keyword"
'() (list (car args)))))))
(else
(body env)))))
(bind-req args))))))))

25
module/ice-9/fdes-finalizers.scm Normal file
View file

@ -0,0 +1,25 @@
;;;; Copyright (C) 2016 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
;;;;
(define-module (ice-9 fdes-finalizers)
#:export (add-fdes-finalizer!
remove-fdes-finalizer!))
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_fdes_finalizers"))

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

@ -1,6 +1,6 @@
;;;; ftw.scm --- file system tree walk
;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014 Free Software Foundation, Inc.
;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014, 2016 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
@ -535,36 +535,30 @@ when FILE-NAME is not readable."
"Return the list of the names of files contained in directory NAME
that match predicate SELECT? (by default, all files.) The returned list
of file names is sorted according to ENTRY<?, which defaults to
`string-locale<?'. Return #f when NAME is unreadable or is not a directory."
(define (enter? dir stat result)
(and stat (string=? dir name)))
`string-locale<?'. Return #f when NAME is unreadable or is not a
directory."
(define (visit basename result)
(if (select? basename)
(cons basename result)
result))
;; This procedure is implemented in terms of 'readdir' instead of
;; 'file-system-fold' to avoid the extra 'stat' call that the latter
;; makes for each entry.
(define (leaf name stat result)
(and result
(visit (basename name) result)))
(define (opendir* directory)
(catch 'system-error
(lambda ()
(opendir directory))
(const #f)))
(define (down name stat result)
(visit "." '()))
(define (up name stat result)
(visit ".." result))
(define (skip name stat result)
;; All the sub-directories are skipped.
(visit (basename name) result))
(define (error name* stat errno result)
(if (string=? name name*) ; top-level NAME is unreadable
result
(visit (basename name*) result)))
(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
(lambda (files)
(sort files entry<?))))
(and=> (opendir* name)
(lambda (stream)
(let loop ((entry (readdir stream))
(files '()))
(if (eof-object? entry)
(begin
(closedir stream)
(sort files entry<?))
(loop (readdir stream)
(if (select? entry)
(cons entry files)
files)))))))
;;; ftw.scm ends here

24
module/ice-9/futures.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;; Copyright (C) 2010, 2011, 2012 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
@ -24,6 +24,7 @@
#:use-module (ice-9 q)
#:use-module (ice-9 match)
#:use-module (ice-9 control)
#:use-module (ice-9 threads)
#:export (future make-future future? touch))
;;; Author: Ludovic Courtès <ludo@gnu.org>
@ -89,14 +90,8 @@ touched."
;; A mapping of nested futures to futures waiting for them to complete.
(define %futures-waiting '())
;; Nesting level of futures. Incremented each time a future is touched
;; from within a future.
(define %nesting-level (make-parameter 0))
;; Maximum nesting level. The point is to avoid stack overflows when
;; nested futures are executed on the same stack. See
;; <http://bugs.gnu.org/13188>.
(define %max-nesting-level 200)
;; Whether currently running within a future.
(define %within-future? (make-parameter #f))
(define-syntax-rule (with-mutex m e0 e1 ...)
;; Copied from (ice-9 threads) to avoid circular dependency.
@ -152,8 +147,7 @@ adding it to the waiter queue."
(thunk (lambda ()
(call-with-prompt %future-prompt
(lambda ()
(parameterize ((%nesting-level
(1+ (%nesting-level))))
(parameterize ((%within-future? #t))
((future-thunk future))))
suspend))))
(set-future-result! future
@ -252,16 +246,14 @@ adding it to the waiter queue."
(unlock-mutex (future-mutex future)))
((started)
(unlock-mutex (future-mutex future))
(if (> (%nesting-level) 0)
(if (%within-future?)
(abort-to-prompt %future-prompt future)
(begin
(work)
(loop))))
(else ; queued
(else
(unlock-mutex (future-mutex future))
(if (> (%nesting-level) %max-nesting-level)
(abort-to-prompt %future-prompt future)
(work))
(work)
(loop))))
((future-result future)))

150
module/ice-9/i18n.scm
View file

@ -1,6 +1,7 @@
;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*-
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012,
;;;; 2017 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
@ -80,7 +81,10 @@
number->locale-string
;; miscellaneous
locale-yes-regexp locale-no-regexp))
locale-yes-regexp locale-no-regexp
;; debugging
%locale-dump))
(eval-when (expand load eval)
@ -211,7 +215,7 @@
MON_DECIMAL_POINT "")
(define-simple-langinfo-mapping locale-monetary-thousands-separator
MON_THOUSANDS_SEP "")
(define-simple-langinfo-mapping locale-monetary-digit-grouping
(define-simple-langinfo-mapping locale-monetary-grouping
MON_GROUPING '())
(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive?
@ -245,6 +249,52 @@
'unspecified 'unspecified)
(define (integer->string number)
"Return a string representing NUMBER, an integer, written in base 10."
(define (digit->char digit)
(integer->char (+ digit (char->integer #\0))))
(if (zero? number)
"0"
(let loop ((number number)
(digits '()))
(if (zero? number)
(list->string digits)
(loop (quotient number 10)
(cons (digit->char (modulo number 10))
digits))))))
(define (number-decimal-string number digit-count)
"Return a string representing the decimal part of NUMBER. When
DIGIT-COUNT is an integer, return exactly DIGIT-COUNT digits; when
DIGIT-COUNT is #t, return as many decimals as necessary, up to an
arbitrary limit."
(define max-decimals
5)
;; XXX: This is brute-force and could be improved by following one of
;; the "Printing Floating-Point Numbers Quickly and Accurately"
;; papers.
(if (integer? digit-count)
(let ((number (* (expt 10 digit-count)
(- number (floor number)))))
(string-pad (integer->string (round (inexact->exact number)))
digit-count
#\0))
(let loop ((decimals 0))
(let ((number' (* number (expt 10 decimals))))
(if (or (= number' (floor number'))
(>= decimals max-decimals))
(let* ((fraction (- number'
(* (floor number)
(expt 10 decimals))))
(str (integer->string
(round (inexact->exact fraction)))))
(if (zero? fraction)
""
str))
(loop (+ decimals 1)))))))
(define (%number-integer-part int grouping separator)
;; Process INT (a string denoting a number's integer part) and return a new
;; string with digit grouping and separators according to GROUPING (a list,
@ -335,13 +385,12 @@ locale is used."
(substring dec 0 fraction-digits)
dec)))))
(external-repr (number->string (if (> amount 0) amount (- amount))))
(int+dec (string-split external-repr #\.))
(int (car int+dec))
(dec (decimal-part (if (null? (cdr int+dec))
""
(cadr int+dec))))
(grouping (locale-monetary-digit-grouping locale))
(int (integer->string (inexact->exact
(floor (abs amount)))))
(dec (decimal-part
(number-decimal-string (abs amount)
fraction-digits)))
(grouping (locale-monetary-grouping locale))
(separator (locale-monetary-thousands-separator locale)))
(add-monetary-sign+currency amount
@ -369,6 +418,7 @@ locale is used."
(locale %global-locale))
"Convert @var{number} (an inexact) into a string according to the cultural
conventions of either @var{locale} (a locale object) or the current locale.
By default, print as many fractional digits as necessary, up to an upper bound.
Optionally, @var{fraction-digits} may be bound to an integer specifying the
number of fractional digits to be displayed."
@ -387,14 +437,11 @@ number of fractional digits to be displayed."
(substring dec 0 fraction-digits)
dec))))))
(let* ((external-repr (number->string (if (> number 0)
number
(- number))))
(int+dec (string-split external-repr #\.))
(int (car int+dec))
(dec (decimal-part (if (null? (cdr int+dec))
""
(cadr int+dec))))
(let* ((int (integer->string (inexact->exact
(floor (abs number)))))
(dec (decimal-part
(number-decimal-string (abs number)
fraction-digits)))
(grouping (locale-digit-grouping locale))
(separator (locale-thousands-separator locale)))
@ -414,4 +461,71 @@ number of fractional digits to be displayed."
;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them.
;;;
;;; Debugging
;;;
(define (%locale-dump loc)
"Given a locale, display an association list containing all the locale
information.
This procedure is intended for debugging locale problems, and should
not be used in production code."
(when (locale? loc)
(list
(cons 'encoding (locale-encoding loc))
(cons 'day-short
(map (lambda (n) (locale-day-short (1+ n) loc)) (iota 7)))
(cons 'day
(map (lambda (n) (locale-day (1+ n) loc)) (iota 7)))
(cons 'month-short
(map (lambda (n) (locale-month-short (1+ n) loc)) (iota 12)))
(cons 'month
(map (lambda (n) (locale-month (1+ n) loc)) (iota 12)))
(cons 'am-string (locale-am-string loc))
(cons 'pm-string (locale-pm-string loc))
(cons 'date+time-format (locale-date+time-format loc))
(cons 'date-format (locale-date-format loc))
(cons 'time-format (locale-time-format loc))
(cons 'time+am/pm-format (locale-time+am/pm-format loc))
(cons 'era (locale-era loc))
(cons 'era-year (locale-era-year loc))
(cons 'era-date-format (locale-era-date-format loc))
(cons 'era-date+time-format (locale-era-date+time-format loc))
(cons 'era-time-format (locale-era-time-format loc))
(cons 'currency-symbol
(list (locale-currency-symbol #t loc)
(locale-currency-symbol #f loc)))
(cons 'monetary-decimal-point (locale-monetary-decimal-point loc))
(cons 'monetary-thousands-separator (locale-monetary-thousands-separator loc))
(cons 'monetary-grouping (locale-monetary-grouping loc))
(cons 'monetary-fractional-digits
(list (locale-monetary-fractional-digits #t loc)
(locale-monetary-fractional-digits #f loc)))
(cons 'currency-symbol-precedes-positive?
(list (locale-currency-symbol-precedes-positive? #t loc)
(locale-currency-symbol-precedes-positive? #f loc)))
(cons 'currency-symbol-precedes-negative?
(list (locale-currency-symbol-precedes-negative? #t loc)
(locale-currency-symbol-precedes-negative? #f loc)))
(cons 'positive-separated-by-space?
(list (locale-positive-separated-by-space? #t loc)
(locale-positive-separated-by-space? #f loc)))
(cons 'negative-separated-by-space?
(list (locale-negative-separated-by-space? #t loc)
(locale-negative-separated-by-space? #f loc)))
(cons 'monetary-positive-sign (locale-monetary-positive-sign loc))
(cons 'monetary-negative-sign (locale-monetary-negative-sign loc))
(cons 'positive-sign-position
(list (locale-positive-sign-position #t loc)
(locale-negative-sign-position #f loc)))
(cons 'negative-sign-position
(list (locale-negative-sign-position #t loc)
(locale-negative-sign-position #f loc)))
(cons 'digit-grouping (locale-digit-grouping loc))
(cons 'decimal-point (locale-decimal-point loc))
(cons 'thousands-separator (locale-thousands-separator loc))
(cons 'locale-yes-regexp (locale-yes-regexp loc))
(cons 'no-regexp (locale-no-regexp loc)))))
;;; i18n.scm ends here

565
module/ice-9/ports.scm Normal file
View file

@ -0,0 +1,565 @@
;;; Ports
;;; Copyright (C) 2016 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/>.
;;; Commentary:
;;;
;;; Implementation of input/output routines over ports.
;;;
;;; Note that loading this module overrides some core bindings; see the
;;; `replace-bootstrap-bindings' invocation below for details.
;;;
;;; Code:
(define-module (ice-9 ports)
#:export (;; Definitions from ports.c.
%port-property
%set-port-property!
current-input-port current-output-port
current-error-port current-warning-port
set-current-input-port set-current-output-port
set-current-error-port
port-mode
port?
input-port?
output-port?
port-closed?
eof-object?
close-port
close-input-port
close-output-port
;; These two are currently defined by scm_init_ports; fix?
;; %default-port-encoding
;; %default-port-conversion-strategy
port-encoding
set-port-encoding!
port-conversion-strategy
set-port-conversion-strategy!
read-char
peek-char
unread-char
unread-string
setvbuf
drain-input
force-output
char-ready?
seek SEEK_SET SEEK_CUR SEEK_END
truncate-file
port-line
set-port-line!
port-column
set-port-column!
port-filename
set-port-filename!
port-for-each
flush-all-ports
%make-void-port
;; Definitions from fports.c.
open-file
file-port?
port-revealed
set-port-revealed!
adjust-port-revealed!
;; note: %file-port-name-canonicalization is used in boot-9
;; Definitions from ioext.c.
ftell
redirect-port
dup->fdes
dup2
fileno
isatty?
fdopen
primitive-move->fdes
fdes->ports
;; Definitions in Scheme
file-position
file-set-position
move->fdes
release-port-handle
dup->port
dup->inport
dup->outport
dup
duplicate-port
fdes->inport
fdes->outport
port->fdes
OPEN_READ OPEN_WRITE OPEN_BOTH
*null-device*
open-input-file
open-output-file
open-io-file
call-with-input-file
call-with-output-file
with-input-from-port
with-output-to-port
with-error-to-port
with-input-from-file
with-output-to-file
with-error-to-file
call-with-input-string
with-input-from-string
call-with-output-string
with-output-to-string
with-error-to-string
the-eof-object
inherit-print-state))
(define (replace-bootstrap-bindings syms)
(for-each
(lambda (sym)
(let* ((var (module-variable the-scm-module sym))
(mod (current-module))
(iface (module-public-interface mod)))
(unless var (error "unbound in root module" sym))
(module-add! mod sym var)
(when (module-local-variable iface sym)
(module-add! iface sym var))))
syms))
(replace-bootstrap-bindings '(open-file
open-input-file
set-port-encoding!
eof-object?
force-output
call-with-output-string
close-port
current-error-port
current-warning-port))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_ports")
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_fports")
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_ioext")
(define (port-encoding port)
"Return, as a string, the character encoding that @var{port} uses to
interpret its input and output."
(symbol->string (%port-encoding port)))
(define-module (ice-9 ports internal)
#:use-module (ice-9 ports)
#:export (port-read-buffer
port-write-buffer
port-auxiliary-write-buffer
port-line-buffered?
expand-port-read-buffer!
port-buffer-bytevector
port-buffer-cur
port-buffer-end
port-buffer-has-eof?
port-buffer-position
set-port-buffer-cur!
set-port-buffer-end!
set-port-buffer-has-eof?!
port-position-line
port-position-column
set-port-position-line!
set-port-position-column!
port-read
port-write
port-clear-stream-start-for-bom-read
port-clear-stream-start-for-bom-write
%port-encoding
specialize-port-encoding!
port-random-access?
port-decode-char
port-encode-char
port-encode-chars
port-read-buffering
port-poll
port-read-wait-fd
port-write-wait-fd
put-char
put-string))
(define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0))
(define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1))
(define-syntax-rule (port-buffer-end buf) (vector-ref buf 2))
(define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3))
(define-syntax-rule (port-buffer-position buf) (vector-ref buf 4))
(define-syntax-rule (set-port-buffer-cur! buf cur)
(vector-set! buf 1 cur))
(define-syntax-rule (set-port-buffer-end! buf end)
(vector-set! buf 2 end))
(define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?)
(vector-set! buf 3 has-eof?))
(define-syntax-rule (port-position-line position)
(car position))
(define-syntax-rule (port-position-column position)
(cdr position))
(define-syntax-rule (set-port-position-line! position line)
(set-car! position line))
(define-syntax-rule (set-port-position-column! position column)
(set-cdr! position column))
(eval-when (expand)
(define-syntax-rule (private-port-bindings binding ...)
(begin
(define binding (@@ (ice-9 ports) binding))
...)))
(private-port-bindings port-read-buffer
port-write-buffer
port-auxiliary-write-buffer
port-line-buffered?
expand-port-read-buffer!
port-read
port-write
port-clear-stream-start-for-bom-read
port-clear-stream-start-for-bom-write
%port-encoding
specialize-port-encoding!
port-decode-char
port-encode-char
port-encode-chars
port-random-access?
port-read-buffering
port-poll
port-read-wait-fd
port-write-wait-fd
put-char
put-string)
;; And we're back.
(define-module (ice-9 ports))
;;; Current ports as parameters.
;;;
(define current-input-port
(fluid->parameter %current-input-port-fluid
(lambda (x)
(unless (input-port? x)
(error "expected an input port" x))
x)))
(define current-output-port
(fluid->parameter %current-output-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
(define current-error-port
(fluid->parameter %current-error-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
(define current-warning-port
(fluid->parameter %current-warning-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
;;; {File Descriptors and Ports}
;;;
(define file-position ftell)
(define* (file-set-position port offset #:optional (whence SEEK_SET))
(seek port offset whence))
(define (move->fdes fd/port fd)
(cond ((integer? fd/port)
(dup->fdes fd/port fd)
(close fd/port)
fd)
(else
(primitive-move->fdes fd/port fd)
(set-port-revealed! fd/port 1)
fd/port)))
(define (release-port-handle port)
(let ((revealed (port-revealed port)))
(if (> revealed 0)
(set-port-revealed! port (- revealed 1)))))
(define dup->port
(case-lambda
((port/fd mode)
(fdopen (dup->fdes port/fd) mode))
((port/fd mode new-fd)
(let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
(set-port-revealed! port 1)
port))))
(define dup->inport
(case-lambda
((port/fd)
(dup->port port/fd "r"))
((port/fd new-fd)
(dup->port port/fd "r" new-fd))))
(define dup->outport
(case-lambda
((port/fd)
(dup->port port/fd "w"))
((port/fd new-fd)
(dup->port port/fd "w" new-fd))))
(define dup
(case-lambda
((port/fd)
(if (integer? port/fd)
(dup->fdes port/fd)
(dup->port port/fd (port-mode port/fd))))
((port/fd new-fd)
(if (integer? port/fd)
(dup->fdes port/fd new-fd)
(dup->port port/fd (port-mode port/fd) new-fd)))))
(define (duplicate-port port modes)
(dup->port port modes))
(define (fdes->inport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "r")))
(set-port-revealed! result 1)
result))
((input-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (fdes->outport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "w")))
(set-port-revealed! result 1)
result))
((output-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (port->fdes port)
(set-port-revealed! port (+ (port-revealed port) 1))
(fileno port))
;; Legacy interfaces.
(define (set-current-input-port port)
"Set the current default input port to @var{port}."
(current-input-port port))
(define (set-current-output-port port)
"Set the current default output port to @var{port}."
(current-output-port port))
(define (set-current-error-port port)
"Set the current default error port to @var{port}."
(current-error-port port))
;;;; high level routines
;;; {High-Level Port Routines}
;;;
;; These are used to request the proper mode to open files in.
;;
(define OPEN_READ "r")
(define OPEN_WRITE "w")
(define OPEN_BOTH "r+")
(define *null-device* "/dev/null")
(define* (open-input-file
file #:key (binary #f) (encoding #f) (guess-encoding #f))
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file file (if binary "rb" "r")
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (open-output-file file #:key (binary #f) (encoding #f))
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
name. If the file cannot be opened, an error is signalled. If a
file with the given name already exists, the effect is unspecified."
(open-file file (if binary "wb" "w")
#:encoding encoding))
(define (open-io-file str)
"Open file with name STR for both input and output."
(open-file str OPEN_BOTH))
(define* (call-with-input-file
file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The file must
already exist. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-input-file file
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The behaviour is unspecified if the file
already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-output-file file #:binary binary #:encoding encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-output-port p)
(apply values vals)))))
(define (with-input-from-port port thunk)
(parameterize ((current-input-port port))
(thunk)))
(define (with-output-to-port port thunk)
(parameterize ((current-output-port port))
(thunk)))
(define (with-error-to-port port thunk)
(parameterize ((current-error-port port))
(thunk)))
(define* (with-input-from-file
file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The file must already exist. The file is opened for
input, an input port connected to it is made
the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-file file
(lambda (p) (with-input-from-port p thunk))
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-output-to-port p thunk))
#:binary binary
#:encoding encoding))
(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-error-to-port p thunk))
#:binary binary
#:encoding encoding))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
input port from which @var{string}'s contents may be read. The value
yielded by the @var{proc} is returned."
(proc (open-input-string string)))
(define (with-input-from-string string thunk)
"THUNK must be a procedure of no arguments.
The test of STRING is opened for
input, an input port connected to it is made,
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed.
Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-string string
(lambda (p) (with-input-from-port p thunk))))
(define (call-with-output-string proc)
"Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
written into the port is returned."
(let ((port (open-output-string)))
(proc port)
(get-output-string port)))
(define (with-output-to-string thunk)
"Calls THUNK and returns its output as a string."
(call-with-output-string
(lambda (p) (with-output-to-port p thunk))))
(define (with-error-to-string thunk)
"Calls THUNK and returns its error output as a string."
(call-with-output-string
(lambda (p) (with-error-to-port p thunk))))
(define (inherit-print-state old-port new-port)
(if (get-print-state old-port)
(port-with-print-state new-port (get-print-state old-port))
new-port))

32
module/ice-9/pretty-print.scm
View file

@ -328,7 +328,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(let ((ellipsis-width (string-length ellipsis)))
(define (print-sequence x width len ref next)
(define* (print-sequence x width len ref next #:key inner?)
(let lp ((x x)
(width width)
(i 0))
@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(cond
((= i len)) ; catches 0-length case
((and (= i (1- len)) (or (zero? i) (> width 1)))
(print (ref x i) (if (zero? i) width (1- width))))
(print (ref x i) (if (zero? i) width (1- width)) #:inner? inner?))
((<= width (+ 1 ellipsis-width))
(display ellipsis))
(else
@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if breadth-first?
(max 1
(1- (floor (/ width (- len i)))))
(- width (+ 1 ellipsis-width))))))))
(- width (+ 1 ellipsis-width)))
#:inner? inner?)))))
(display str)
(lp (next x) (- width 1 (string-length str)) (1+ i)))))))
@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(else
(lp (cdr fixes))))))
(define (print x width)
(define* (print x width #:key inner?)
(cond
((<= width 0)
(error "expected a positive width" width))
@ -428,6 +429,29 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(display ")"))
(else
(display "#"))))
((and (array? x) (not (string? x)))
(let* ((type (array-type x))
(prefix
(if inner?
""
(if (zero? (array-rank x))
(string-append "#0" (if (eq? #t type) "" (symbol->string type)))
(let ((s (format #f "~a"
(apply make-typed-array type *unspecified*
(make-list (array-rank x) 0)))))
(substring s 0 (- (string-length s) 2))))))
(width-prefix (string-length prefix)))
(cond
((>= width (+ 2 width-prefix ellipsis-width))
(format #t "~a(" prefix)
(if (zero? (array-rank x))
(print (array-ref x) (- width width-prefix 2))
(print-sequence x (- width width-prefix 2) (array-length x)
array-cell-ref identity
#:inner? (< 1 (array-rank x))))
(display ")"))
(else
(display "#")))))
((pair? x)
(cond
((>= width (+ 4 ellipsis-width))

6787
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

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

@ -1,7 +1,7 @@
;;;; -*-scheme-*-
;;;;
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
;;;; 2012, 2013, 2015 Free Software Foundation, Inc.
;;;; 2012, 2013, 2015, 2016 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
@ -165,7 +165,12 @@
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
(let ()
(let ((syntax? (module-ref (current-module) 'syntax?))
(make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module)))
(define-syntax define-expansion-constructors
(lambda (x)
(syntax-case x ()
@ -461,11 +466,31 @@
(make-letrec src in-order? ids vars val-exps body-exp)))))
;; FIXME: use a faster gensym
(define-syntax-rule (build-lexical-var src id)
(gensym (string-append (symbol->string id) "-")))
;; Use a per-module counter instead of the global counter of
;; 'gensym' so that the generated identifier is reproducible.
(module-gensym (symbol->string id)))
(define-structure (syntax-object expression wrap module))
(define (syntax-object? x)
(or (syntax? x)
(and (allow-legacy-syntax-objects?)
(vector? x)
(= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object))))
(define (make-syntax-object expression wrap module)
(make-syntax expression wrap module))
(define (syntax-object-expression obj)
(if (syntax? obj)
(syntax-expression obj)
(vector-ref obj 1)))
(define (syntax-object-wrap obj)
(if (syntax? obj)
(syntax-wrap obj)
(vector-ref obj 2)))
(define (syntax-object-module obj)
(if (syntax? obj)
(syntax-module obj)
(vector-ref obj 3)))
(define-syntax no-source (identifier-syntax #f))
@ -632,7 +657,7 @@
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
(string-append "l-" (session-id) (symbol->string (gensym "-"))))
(symbol->string (module-gensym "l")))
(define gen-labels
(lambda (ls)
@ -661,7 +686,7 @@
(cons 'shift (wrap-subst w)))))
(define-syntax-rule (new-mark)
(gensym (string-append "m-" (session-id) "-")))
(module-gensym "m"))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally
@ -1087,9 +1112,18 @@
(append (parse1 (car body) r w s m esew mod)
exps)))))
(define (parse1 x r w s m esew mod)
(define (current-module-for-expansion mod)
(case (car mod)
;; If the module was just put in place for hygiene, in a
;; top-level `begin' always recapture the current
;; module. If a user wants to override, then we need to
;; use @@ or similar.
((hygiene) (cons 'hygiene (module-name (current-module))))
(else mod)))
(call-with-values
(lambda ()
(syntax-type x r w (source-annotation x) ribcage mod #f))
(let ((mod (current-module-for-expansion mod)))
(syntax-type x r w (source-annotation x) ribcage mod #f)))
(lambda (type value form e w s mod)
(case type
((define-form)
@ -2708,7 +2742,9 @@
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls))))
(map (lambda (x)
(wrap (module-gensym "t") top-wrap mod))
ls))))
(set! free-identifier=?
(lambda (x y)
@ -2734,7 +2770,7 @@
(and subform (strip subform empty-wrap)))))
(let ()
(define (syntax-module id)
(define (%syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
(let ((mod (syntax-object-module id)))
(and (not (equal? mod '(primitive)))
@ -2785,7 +2821,7 @@
;; compile-time, after the variables are stolen away into (system
;; syntax). See the end of boot-9.scm.
;;
(define! 'syntax-module syntax-module)
(define! '%syntax-module %syntax-module)
(define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
@ -2849,7 +2885,8 @@
(match (car e) (car y-pat) w r mod)))
(values #f #f #f)))))
((syntax-object? e)
(f (syntax-object-expression e) (join-wraps w e)))
(f (syntax-object-expression e)
(join-wraps w (syntax-object-wrap e))))
(else
(values '() y-pat (match e z-pat w r mod)))))))
@ -3183,7 +3220,7 @@
(result '()))
(if (eof-object? x)
(begin
(close-input-port p)
(close-port p)
(reverse result))
(f (read p)
(cons (datum->syntax k x) result)))))))
@ -3203,10 +3240,11 @@
(let ((fn (syntax->datum #'filename)))
(with-syntax ((fn (datum->syntax
#'filename
(or (%search-load-path fn)
(syntax-violation 'include-from-path
"file not found in path"
x #'filename)))))
(canonicalize-path
(or (%search-load-path fn)
(syntax-violation 'include-from-path
"file not found in path"
x #'filename))))))
#'(include fn)))))))
(define-syntax unquote

34
module/ice-9/r6rs-libraries.scm
View file

@ -26,6 +26,17 @@
(set-module-kind! iface 'custom-interface)
(set-module-name! iface (module-name mod))
iface))
(define (module-for-each/nonlocal f mod)
(define (module-and-uses mod)
(let lp ((in (list mod)) (out '()))
(cond
((null? in) (reverse out))
((memq (car in) out) (lp (cdr in) out))
(else (lp (append (module-uses (car in)) (cdr in))
(cons (car in) out))))))
(for-each (lambda (mod)
(module-for-each f mod))
(module-and-uses mod)))
(define (sym? x) (symbol? (syntax->datum x)))
(syntax-case import-spec (library only except prefix rename srfi)
@ -63,7 +74,7 @@
(iface (make-custom-interface mod)))
(for-each (lambda (sym)
(module-add! iface sym
(or (module-local-variable mod sym)
(or (module-variable mod sym)
(error "no binding `~A' in module ~A"
sym mod))))
(syntax->datum #'(identifier ...)))
@ -73,7 +84,9 @@
(and-map sym? #'(identifier ...))
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod)))
(module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
(module-for-each/nonlocal (lambda (sym var)
(module-add! iface sym var))
mod)
(for-each (lambda (sym)
(if (module-local-variable iface sym)
(module-remove! iface sym)
@ -86,16 +99,19 @@
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod))
(pre (syntax->datum #'identifier)))
(module-for-each (lambda (sym var)
(module-add! iface (symbol-append pre sym) var))
mod)
(module-for-each/nonlocal
(lambda (sym var)
(module-add! iface (symbol-append pre sym) var))
mod)
iface))
((rename import-set (from to) ...)
(and (and-map sym? #'(from ...)) (and-map sym? #'(to ...)))
(let* ((mod (resolve-r6rs-interface #'import-set))
(iface (make-custom-interface mod)))
(module-for-each (lambda (sym var) (module-add! iface sym var)) mod)
(module-for-each/nonlocal
(lambda (sym var) (module-add! iface sym var))
mod)
(let lp ((in (syntax->datum #'((from . to) ...))) (out '()))
(cond
((null? in)
@ -108,7 +124,7 @@
out)
iface)
(else
(let ((var (or (module-local-variable mod (caar in))
(let ((var (or (module-variable mod (caar in))
(error "no binding `~A' in module ~A"
(caar in) mod))))
(module-remove! iface (caar in))
@ -126,9 +142,9 @@
(lambda (stx)
(define (compute-exports ifaces specs)
(define (re-export? sym)
(or-map (lambda (iface) (module-local-variable iface sym)) ifaces))
(or-map (lambda (iface) (module-variable iface sym)) ifaces))
(define (replace? sym)
(module-local-variable the-scm-module sym))
(module-variable the-scm-module sym))
(let lp ((specs specs) (e '()) (r '()) (x '()))
(syntax-case specs (rename)

19
module/ice-9/rdelim.scm
View file

@ -156,13 +156,20 @@ If the COUNT argument is present, treat it as a limit to the number of
characters to read. By default, there is no limit."
((#:optional (port (current-input-port)))
;; Fast path.
;; This creates more garbage than using 'string-set!' as in
;; 'read-string!', but currently that is faster nonetheless.
(let loop ((chars '()))
(let loop ((head (make-string 30)) (pos 0) (tail '()))
(let ((char (read-char port)))
(if (eof-object? char)
(list->string (reverse! chars))
(loop (cons char chars))))))
(cond
((eof-object? char)
(let ((head (substring head 0 pos)))
(if (null? tail)
(substring head 0 pos)
(string-concatenate-reverse tail head pos))))
(else
(string-set! head pos char)
(if (< (1+ pos) (string-length head))
(loop head (1+ pos) tail)
(loop (make-string (* (string-length head) 2)) 0
(cons head tail))))))))
((port count)
;; Slower path.
(let loop ((chars '())

1399
module/ice-9/sandbox.scm Normal file
View file

File diff suppressed because it is too large Load diff

2
module/ice-9/save-stack.scm
View file

@ -53,6 +53,6 @@
;; if any.
(apply make-stack #t
2
(if (pair? stacks) (cdar stacks) 0)
(if (pair? stacks) (cdr stacks) 0)
narrowing)))
(set! stack-saved? #t))))

10
module/ice-9/serialize.scm
View file

@ -71,16 +71,16 @@
(lambda ()
(lock-mutex admin-mutex)
(set! outer-owner owner)
(if (not (eqv? outer-owner (dynamic-root)))
(if (not (eqv? outer-owner (current-thread)))
(begin
(unlock-mutex admin-mutex)
(lock-mutex serialization-mutex)
(set! owner (dynamic-root)))
(set! owner (current-thread)))
(unlock-mutex admin-mutex)))
thunk
(lambda ()
(lock-mutex admin-mutex)
(if (not (eqv? outer-owner (dynamic-root)))
(if (not (eqv? outer-owner (current-thread)))
(begin
(set! owner #f)
(unlock-mutex serialization-mutex)))
@ -95,7 +95,7 @@
(lambda ()
(lock-mutex admin-mutex)
(set! outer-owner owner)
(if (eqv? outer-owner (dynamic-root))
(if (eqv? outer-owner (current-thread))
(begin
(set! owner #f)
(unlock-mutex serialization-mutex)))
@ -103,7 +103,7 @@
thunk
(lambda ()
(lock-mutex admin-mutex)
(if (eqv? outer-owner (dynamic-root))
(if (eqv? outer-owner (current-thread))
(begin
(unlock-mutex admin-mutex)
(lock-mutex serialization-mutex)

737
module/ice-9/suspendable-ports.scm Normal file
View file

@ -0,0 +1,737 @@
;;; Ports, implemented in Scheme
;;; Copyright (C) 2016 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/>.
;;; Commentary:
;;;
;;; We would like to be able to implement green threads using delimited
;;; continuations. When a green thread would block on I/O, it should
;;; suspend and arrange to be resumed when it can make progress.
;;;
;;; The problem is that the ports code is written in C. A delimited
;;; continuation that captures a C activation can't be resumed, because
;;; Guile doesn't know about the internal structure of the C activation
;;; (stack frame) and so can't compose it with the current continuation.
;;; For that reason, to implement this desired future, we have to
;;; implement ports in Scheme.
;;;
;;; If Scheme were fast enough, we would just implement ports in Scheme
;;; early in Guile's boot, and that would be that. However currently
;;; that's not the case: character-by-character I/O is about three or
;;; four times slower in Scheme than in C. This is mostly bytecode
;;; overhead, though there are some ways that compiler improvements
;;; could help us too.
;;;
;;; Note that the difference between Scheme and C is much less for
;;; batched operations, like read-bytes or read-line.
;;;
;;; So the upshot is that we need to keep the C I/O routines around for
;;; performance reasons. We can still have our Scheme routines
;;; available as a module, though, for use by people working with green
;;; threads. That's this module. People that want green threads can
;;; even replace the core bindings, which enables green threading over
;;; other generic routines like the HTTP server.
;;;
;;; Code:
(define-module (ice-9 suspendable-ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 ports internal)
#:use-module (ice-9 match)
#:export (current-read-waiter
current-write-waiter
install-suspendable-ports!
uninstall-suspendable-ports!))
(define (default-read-waiter port) (port-poll port "r"))
(define (default-write-waiter port) (port-poll port "w"))
(define current-read-waiter (make-parameter default-read-waiter))
(define current-write-waiter (make-parameter default-write-waiter))
(define (wait-for-readable port) ((current-read-waiter) port))
(define (wait-for-writable port) ((current-write-waiter) port))
(define (read-bytes port dst start count)
(cond
(((port-read port) port dst start count)
=> (lambda (read)
(unless (<= 0 read count)
(error "bad return from port read function" read))
read))
(else
(wait-for-readable port)
(read-bytes port dst start count))))
(define (write-bytes port src start count)
(cond
(((port-write port) port src start count)
=> (lambda (written)
(unless (<= 0 written count)
(error "bad return from port write function" written))
(when (< written count)
(write-bytes port src (+ start written) (- count written)))))
(else
(wait-for-writable port)
(write-bytes port src start count))))
(define (flush-input port)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(end (port-buffer-end buf)))
(when (< cur end)
(set-port-buffer-cur! buf 0)
(set-port-buffer-end! buf 0)
(seek port (- cur end) SEEK_CUR))))
(define (flush-output port)
(let* ((buf (port-write-buffer port))
(cur (port-buffer-cur buf))
(end (port-buffer-end buf)))
(when (< cur end)
;; Update cursors before attempting to write, assuming that I/O
;; errors are sticky. That way if the write throws an error,
;; causing the computation to abort, and possibly causing the port
;; to be collected by GC when it's open, any subsequent close-port
;; or force-output won't signal *another* error.
(set-port-buffer-cur! buf 0)
(set-port-buffer-end! buf 0)
(write-bytes port (port-buffer-bytevector buf) cur (- end cur)))))
(define utf8-bom #vu8(#xEF #xBB #xBF))
(define utf16be-bom #vu8(#xFE #xFF))
(define utf16le-bom #vu8(#xFF #xFE))
(define utf32be-bom #vu8(#x00 #x00 #xFE #xFF))
(define utf32le-bom #vu8(#xFF #xFE #x00 #x00))
(define (clear-stream-start-for-bom-read port io-mode)
(define (maybe-consume-bom bom)
(and (eq? (peek-byte port) (bytevector-u8-ref bom 0))
(call-with-values (lambda ()
(fill-input port (bytevector-length bom)))
(lambda (buf cur buffered)
(and (<= (bytevector-length bom) buffered)
(let ((bv (port-buffer-bytevector buf)))
(let lp ((i 1))
(if (= i (bytevector-length bom))
(begin
(set-port-buffer-cur! buf (+ cur i))
#t)
(and (eq? (bytevector-u8-ref bv (+ cur i))
(bytevector-u8-ref bom i))
(lp (1+ i)))))))))))
(when (and (port-clear-stream-start-for-bom-read port)
(eq? io-mode 'text))
(case (%port-encoding port)
((UTF-8)
(maybe-consume-bom utf8-bom))
((UTF-16)
(cond
((maybe-consume-bom utf16le-bom)
(specialize-port-encoding! port 'UTF-16LE))
(else
(maybe-consume-bom utf16be-bom)
(specialize-port-encoding! port 'UTF-16BE))))
((UTF-32)
(cond
((maybe-consume-bom utf32le-bom)
(specialize-port-encoding! port 'UTF-32LE))
(else
(maybe-consume-bom utf32be-bom)
(specialize-port-encoding! port 'UTF-32BE)))))))
(define* (fill-input port #:optional (minimum-buffering 1) (io-mode 'text))
(clear-stream-start-for-bom-read port io-mode)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(buffered (max (- (port-buffer-end buf) cur) 0)))
(cond
((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf))
(values buf cur buffered))
(else
(unless (input-port? port)
(error "not an input port" port))
(when (port-random-access? port)
(flush-output port))
(let ((bv (port-buffer-bytevector buf)))
(cond
((< (bytevector-length bv) minimum-buffering)
(expand-port-read-buffer! port minimum-buffering)
(fill-input port minimum-buffering))
(else
(when (< 0 cur)
(bytevector-copy! bv cur bv 0 buffered)
(set-port-buffer-cur! buf 0)
(set-port-buffer-end! buf buffered))
(let ((buffering (max (port-read-buffering port) minimum-buffering)))
(let lp ((buffered buffered))
(let* ((count (- buffering buffered))
(read (read-bytes port bv buffered count)))
(cond
((zero? read)
(set-port-buffer-has-eof?! buf #t)
(values buf 0 buffered))
(else
(let ((buffered (+ buffered read)))
(set-port-buffer-end! buf buffered)
(if (< buffered minimum-buffering)
(lp buffered)
(values buf 0 buffered)))))))))))))))
(define* (force-output #:optional (port (current-output-port)))
(unless (and (output-port? port) (not (port-closed? port)))
(error "not an open output port" port))
(flush-output port))
(define close-port
(let ((%close-port (@ (guile) close-port)))
(lambda (port)
(cond
((port-closed? port) #f)
(else
(when (output-port? port) (flush-output port))
(%close-port port))))))
(define-inlinable (peek-bytes port count kfast kslow)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(buffered (- (port-buffer-end buf) cur)))
(if (<= count buffered)
(kfast buf (port-buffer-bytevector buf) cur buffered)
(call-with-values (lambda () (fill-input port count))
(lambda (buf cur buffered)
(kslow buf (port-buffer-bytevector buf) cur buffered))))))
(define (peek-byte port)
(peek-bytes port 1
(lambda (buf bv cur buffered)
(bytevector-u8-ref bv cur))
(lambda (buf bv cur buffered)
(and (> buffered 0)
(bytevector-u8-ref bv cur)))))
(define* (lookahead-u8 port)
(define (fast-path buf bv cur buffered)
(bytevector-u8-ref bv cur))
(define (slow-path buf bv cur buffered)
(if (zero? buffered)
the-eof-object
(fast-path buf bv cur buffered)))
(peek-bytes port 1 fast-path slow-path))
(define* (get-u8 port)
(define (fast-path buf bv cur buffered)
(set-port-buffer-cur! buf (1+ cur))
(bytevector-u8-ref bv cur))
(define (slow-path buf bv cur buffered)
(if (zero? buffered)
(begin
(set-port-buffer-has-eof?! buf #f)
the-eof-object)
(fast-path buf bv cur buffered)))
(peek-bytes port 1 fast-path slow-path))
(define* (get-bytevector-n port count)
(let ((ret (make-bytevector count)))
(define (port-buffer-take! pos buf cur to-copy)
(bytevector-copy! (port-buffer-bytevector buf) cur
ret pos to-copy)
(set-port-buffer-cur! buf (+ cur to-copy))
(+ pos to-copy))
(define (take-already-buffered)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf))
(buffered (max (- (port-buffer-end buf) cur) 0)))
(port-buffer-take! 0 buf cur (min count buffered))))
(define (trim-and-return len)
(if (zero? len)
the-eof-object
(let ((partial (make-bytevector len)))
(bytevector-copy! ret 0 partial 0 len)
partial)))
(define (buffer-and-fill pos)
(call-with-values (lambda () (fill-input port 1 'binary))
(lambda (buf cur buffered)
(if (zero? buffered)
(begin
(set-port-buffer-has-eof?! buf #f)
(trim-and-return pos))
(let ((pos (port-buffer-take! pos buf cur
(min (- count pos) buffered))))
(if (= pos count)
ret
(buffer-and-fill pos)))))))
(define (fill-directly pos)
(when (port-random-access? port)
(flush-output port))
(port-clear-stream-start-for-bom-read port)
(let lp ((pos pos))
(let ((read (read-bytes port ret pos (- count pos))))
(cond
((= read (- count pos)) ret)
((zero? read) (trim-and-return pos))
(else (lp (+ pos read)))))))
(let ((pos (take-already-buffered)))
(cond
((= pos count) (if (zero? pos) the-eof-object ret))
((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos))
(else (fill-directly pos))))))
(define (put-u8 port byte)
(let* ((buf (port-write-buffer port))
(bv (port-buffer-bytevector buf))
(end (port-buffer-end buf)))
(unless (<= 0 end (bytevector-length bv))
(error "not an output port" port))
(when (and (eq? (port-buffer-cur buf) end) (port-random-access? port))
(flush-input port))
(cond
((= end (bytevector-length bv))
;; Multiple threads racing; race to flush, then retry.
(flush-output port)
(put-u8 port byte))
(else
(bytevector-u8-set! bv end byte)
(set-port-buffer-end! buf (1+ end))
(when (= (1+ end) (bytevector-length bv)) (flush-output port))))))
(define* (put-bytevector port src #:optional (start 0)
(count (- (bytevector-length src) start)))
(unless (<= 0 start (+ start count) (bytevector-length src))
(error "invalid start/count" start count))
(let* ((buf (port-write-buffer port))
(bv (port-buffer-bytevector buf))
(size (bytevector-length bv))
(cur (port-buffer-cur buf))
(end (port-buffer-end buf))
(buffered (max (- end cur) 0)))
(when (and (eq? cur end) (port-random-access? port))
(flush-input port))
(cond
((<= size count)
;; The write won't fit in the buffer at all; write directly.
;; Write directly. Flush write buffer first if needed.
(when (< cur end) (flush-output port))
(write-bytes port src start count))
((< (- size buffered) count)
;; The write won't fit into the buffer along with what's already
;; buffered. Flush and fill.
(flush-output port)
(set-port-buffer-end! buf count)
(bytevector-copy! src start bv 0 count))
(else
;; The write will fit in the buffer, but we need to shuffle the
;; already-buffered bytes (if any) down.
(set-port-buffer-cur! buf 0)
(set-port-buffer-end! buf (+ buffered count))
(bytevector-copy! bv cur bv 0 buffered)
(bytevector-copy! src start bv buffered count)
;; If the buffer completely fills, we flush.
(when (= (+ buffered count) size)
(flush-output port))))))
(define (decoding-error subr port)
;; GNU definition; fixme?
(define EILSEQ 84)
(throw 'decoding-error subr "input decoding error" EILSEQ port))
(define-inlinable (decode-utf8 bv start avail u8_0 kt kf)
(cond
((< u8_0 #x80)
(kt (integer->char u8_0) 1))
((and (<= #xc2 u8_0 #xdf) (<= 2 avail))
(let ((u8_1 (bytevector-u8-ref bv (1+ start))))
(if (= (logand u8_1 #xc0) #x80)
(kt (integer->char
(logior (ash (logand u8_0 #x1f) 6)
(logand u8_1 #x3f)))
2)
(kf))))
((and (= (logand u8_0 #xf0) #xe0) (<= 3 avail))
(let ((u8_1 (bytevector-u8-ref bv (+ start 1)))
(u8_2 (bytevector-u8-ref bv (+ start 2))))
(if (and (= (logand u8_1 #xc0) #x80)
(= (logand u8_2 #xc0) #x80)
(case u8_0
((#xe0) (>= u8_1 #xa0))
((#xed) (>= u8_1 #x9f))
(else #t)))
(kt (integer->char
(logior (ash (logand u8_0 #x0f) 12)
(ash (logand u8_1 #x3f) 6)
(logand u8_2 #x3f)))
3)
(kf))))
((and (<= #xf0 u8_0 #xf4) (<= 4 avail))
(let ((u8_1 (bytevector-u8-ref bv (+ start 1)))
(u8_2 (bytevector-u8-ref bv (+ start 2)))
(u8_3 (bytevector-u8-ref bv (+ start 3))))
(if (and (= (logand u8_1 #xc0) #x80)
(= (logand u8_2 #xc0) #x80)
(= (logand u8_3 #xc0) #x80)
(case u8_0
((#xf0) (>= u8_1 #x90))
((#xf4) (>= u8_1 #x8f))
(else #t)))
(kt (integer->char
(logior (ash (logand u8_0 #x07) 18)
(ash (logand u8_1 #x3f) 12)
(ash (logand u8_2 #x3f) 6)
(logand u8_3 #x3f)))
4)
(kf))))
(else (kf))))
(define (bad-utf8-len bv cur buffering first-byte)
(define (ref n)
(bytevector-u8-ref bv (+ cur n)))
(cond
((< first-byte #x80) 0)
((<= #xc2 first-byte #xdf)
(cond
((< buffering 2) 1)
((not (= (logand (ref 1) #xc0) #x80)) 1)
(else 0)))
((= (logand first-byte #xf0) #xe0)
(cond
((< buffering 2) 1)
((not (= (logand (ref 1) #xc0) #x80)) 1)
((and (eq? first-byte #xe0) (< (ref 1) #xa0)) 1)
((and (eq? first-byte #xed) (< (ref 1) #x9f)) 1)
((< buffering 3) 2)
((not (= (logand (ref 2) #xc0) #x80)) 2)
(else 0)))
((<= #xf0 first-byte #xf4)
(cond
((< buffering 2) 1)
((not (= (logand (ref 1) #xc0) #x80)) 1)
((and (eq? first-byte #xf0) (< (ref 1) #x90)) 1)
((and (eq? first-byte #xf4) (< (ref 1) #x8f)) 1)
((< buffering 3) 2)
((not (= (logand (ref 2) #xc0) #x80)) 2)
((< buffering 4) 3)
((not (= (logand (ref 3) #xc0) #x80)) 3)
(else 0)))
(else 1)))
(define (peek-char-and-next-cur/utf8 port buf cur first-byte)
(if (< first-byte #x80)
(values (integer->char first-byte) buf (+ cur 1))
(call-with-values (lambda ()
(fill-input port
(cond
((<= #xc2 first-byte #xdf) 2)
((= (logand first-byte #xf0) #xe0) 3)
(else 4))))
(lambda (buf cur buffering)
(let ((bv (port-buffer-bytevector buf)))
(define (bad-utf8)
(let ((len (bad-utf8-len bv cur buffering first-byte)))
(when (zero? len) (error "internal error"))
(if (eq? (port-conversion-strategy port) 'substitute)
(values #\xFFFD buf (+ cur len))
(decoding-error "peek-char" port))))
(decode-utf8 bv cur buffering first-byte
(lambda (char len)
(values char buf (+ cur len)))
bad-utf8))))))
(define (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte)
(values (integer->char first-byte) buf (+ cur 1)))
(define (peek-char-and-next-cur/iconv port)
(let lp ((prev-input-size 0))
(let ((input-size (1+ prev-input-size)))
(call-with-values (lambda () (fill-input port input-size))
(lambda (buf cur buffered)
(cond
((< buffered input-size)
;; Buffer failed to fill; EOF, possibly premature.
(cond
((zero? prev-input-size)
(values the-eof-object buf cur))
((eq? (port-conversion-strategy port) 'substitute)
(values #\xFFFD buf (+ cur prev-input-size)))
(else
(decoding-error "peek-char" port))))
((port-decode-char port (port-buffer-bytevector buf)
cur input-size)
=> (lambda (char)
(values char buf (+ cur input-size))))
(else
(lp input-size))))))))
(define (peek-char-and-next-cur port)
(define (have-byte buf bv cur buffered)
(let ((first-byte (bytevector-u8-ref bv cur)))
(case (%port-encoding port)
((UTF-8)
(peek-char-and-next-cur/utf8 port buf cur first-byte))
((ISO-8859-1)
(peek-char-and-next-cur/iso-8859-1 port buf cur first-byte))
(else
(peek-char-and-next-cur/iconv port)))))
(peek-bytes port 1 have-byte
(lambda (buf bv cur buffered)
(if (< 0 buffered)
(have-byte buf bv cur buffered)
(values the-eof-object buf cur)))))
(define* (peek-char #:optional (port (current-input-port)))
(define (slow-path)
(call-with-values (lambda () (peek-char-and-next-cur port))
(lambda (char buf cur)
char)))
(define (fast-path buf bv cur buffered)
(let ((u8 (bytevector-u8-ref bv cur))
(enc (%port-encoding port)))
(case enc
((UTF-8) (decode-utf8 bv cur buffered u8 (lambda (char len) char)
slow-path))
((ISO-8859-1) (integer->char u8))
(else (slow-path)))))
(peek-bytes port 1 fast-path
(lambda (buf bv cur buffered) (slow-path))))
(define-inlinable (advance-port-position! pos char)
;; FIXME: this cond is a speed hack; really we should just compile
;; `case' better.
(cond
;; FIXME: char>? et al should compile well.
((<= (char->integer #\space) (char->integer char))
(set-port-position-column! pos (1+ (port-position-column pos))))
(else
(case char
((#\alarm) #t) ; No change.
((#\backspace)
(let ((col (port-position-column pos)))
(when (> col 0)
(set-port-position-column! pos (1- col)))))
((#\newline)
(set-port-position-line! pos (1+ (port-position-line pos)))
(set-port-position-column! pos 0))
((#\return)
(set-port-position-column! pos 0))
((#\tab)
(let ((col (port-position-column pos)))
(set-port-position-column! pos (- (+ col 8) (remainder col 8)))))
(else
(set-port-position-column! pos (1+ (port-position-column pos))))))))
(define* (read-char #:optional (port (current-input-port)))
(define (finish buf char)
(advance-port-position! (port-buffer-position buf) char)
char)
(define (slow-path)
(call-with-values (lambda () (peek-char-and-next-cur port))
(lambda (char buf cur)
(set-port-buffer-cur! buf cur)
(if (eq? char the-eof-object)
(begin
(set-port-buffer-has-eof?! buf #f)
char)
(finish buf char)))))
(define (fast-path buf bv cur buffered)
(let ((u8 (bytevector-u8-ref bv cur))
(enc (%port-encoding port)))
(case enc
((UTF-8)
(decode-utf8 bv cur buffered u8
(lambda (char len)
(set-port-buffer-cur! buf (+ cur len))
(finish buf char))
slow-path))
((ISO-8859-1)
(set-port-buffer-cur! buf (+ cur 1))
(finish buf (integer->char u8)))
(else (slow-path)))))
(peek-bytes port 1 fast-path
(lambda (buf bv cur buffered) (slow-path))))
(define-inlinable (port-fold-chars/iso-8859-1 port proc seed)
(let* ((buf (port-read-buffer port))
(cur (port-buffer-cur buf)))
(let fold-buffer ((buf buf) (cur cur) (seed seed))
(let ((bv (port-buffer-bytevector buf))
(end (port-buffer-end buf)))
(let fold-chars ((cur cur) (seed seed))
(cond
((= end cur)
(call-with-values (lambda () (fill-input port))
(lambda (buf cur buffered)
(if (zero? buffered)
(call-with-values (lambda () (proc the-eof-object seed))
(lambda (seed done?)
(if done? seed (fold-buffer buf cur seed))))
(fold-buffer buf cur seed)))))
(else
(let ((ch (integer->char (bytevector-u8-ref bv cur)))
(cur (1+ cur)))
(set-port-buffer-cur! buf cur)
(advance-port-position! (port-buffer-position buf) ch)
(call-with-values (lambda () (proc ch seed))
(lambda (seed done?)
(if done? seed (fold-chars cur seed))))))))))))
(define-inlinable (port-fold-chars port proc seed)
(case (%port-encoding port)
((ISO-8859-1) (port-fold-chars/iso-8859-1 port proc seed))
(else
(let lp ((seed seed))
(let ((ch (read-char port)))
(call-with-values (lambda () (proc ch seed))
(lambda (seed done?)
(if done? seed (lp seed)))))))))
(define* (read-delimited delims #:optional (port (current-input-port))
(handle-delim 'trim))
;; Currently this function conses characters into a list, then uses
;; reverse-list->string. It wastes 2 words per character but it still
;; seems to be the fastest thing at the moment.
(define (finish delim chars)
(define (->string chars)
(if (and (null? chars) (not (char? delim)))
the-eof-object
(reverse-list->string chars)))
(case handle-delim
((trim) (->string chars))
((split) (cons (->string chars) delim))
((concat)
(->string (if (char? delim) (cons delim chars) chars)))
((peek)
(when (char? delim) (unread-char delim port))
(->string chars))
(else
(error "unexpected handle-delim value: " handle-delim))))
(define-syntax-rule (make-folder delimiter?)
(lambda (char chars)
(if (or (not (char? char)) (delimiter? char))
(values (finish char chars) #t)
(values (cons char chars) #f))))
(define-syntax-rule (specialized-fold delimiter?)
(port-fold-chars port (make-folder delimiter?) '()))
(case (string-length delims)
((0) (specialized-fold (lambda (char) #f)))
((1) (let ((delim (string-ref delims 0)))
(specialized-fold (lambda (char) (eqv? char delim)))))
(else => (lambda (ndelims)
(specialized-fold
(lambda (char)
(let lp ((i 0))
(and (< i ndelims)
(or (eqv? char (string-ref delims i))
(lp (1+ i)))))))))))
(define* (read-line #:optional (port (current-input-port))
(handle-delim 'trim))
(read-delimited "\n" port handle-delim))
(define* (%read-line port)
(read-line port 'split))
(define* (put-string port str #:optional (start 0)
(count (- (string-length str) start)))
(let* ((aux (port-auxiliary-write-buffer port))
(pos (port-buffer-position aux))
(line (port-position-line pos)))
(set-port-buffer-cur! aux 0)
(port-clear-stream-start-for-bom-write port aux)
(let lp ((encoded 0))
(when (< encoded count)
(let ((encoded (+ encoded
(port-encode-chars port aux str
(+ start encoded)
(- count encoded)))))
(let ((end (port-buffer-end aux)))
(set-port-buffer-end! aux 0)
(put-bytevector port (port-buffer-bytevector aux) 0 end)
(lp encoded)))))
(when (and (not (eqv? line (port-position-line pos)))
(port-line-buffered? port))
(flush-output port))))
(define* (put-char port char)
(let ((aux (port-auxiliary-write-buffer port)))
(set-port-buffer-cur! aux 0)
(port-clear-stream-start-for-bom-write port aux)
(port-encode-char port aux char)
(let ((end (port-buffer-end aux)))
(set-port-buffer-end! aux 0)
(put-bytevector port (port-buffer-bytevector aux) 0 end))
(when (and (eqv? char #\newline) (port-line-buffered? port))
(flush-output port))))
(define accept
(let ((%accept (@ (guile) accept)))
(lambda* (port #:optional (flags 0))
(let lp ()
(or (%accept port flags)
(begin
(wait-for-readable port)
(lp)))))))
(define connect
(let ((%connect (@ (guile) connect)))
(lambda (port sockaddr . args)
(unless (apply %connect port sockaddr args)
;; Clownshoes semantics; see connect(2).
(wait-for-writable port)
(let ((err (getsockopt port SOL_SOCKET SO_ERROR)))
(unless (zero? err)
(scm-error 'system-error "connect" "~A"
(list (strerror err)) #f)))))))
(define saved-port-bindings #f)
(define port-bindings
'(((guile)
read-char peek-char force-output close-port
accept connect)
((ice-9 binary-ports)
get-u8 lookahead-u8 get-bytevector-n
put-u8 put-bytevector)
((ice-9 textual-ports)
put-char put-string)
((ice-9 rdelim) %read-line read-line read-delimited)))
(define (install-suspendable-ports!)
(unless saved-port-bindings
(set! saved-port-bindings (make-hash-table))
(let ((suspendable-ports (resolve-module '(ice-9 suspendable-ports))))
(for-each
(match-lambda
((mod . syms)
(let ((mod (resolve-module mod)))
(for-each (lambda (sym)
(hashq-set! saved-port-bindings sym
(module-ref mod sym))
(module-set! mod sym
(module-ref suspendable-ports sym)))
syms))))
port-bindings))))
(define (uninstall-suspendable-ports!)
(when saved-port-bindings
(for-each
(match-lambda
((mod . syms)
(let ((mod (resolve-module mod)))
(for-each (lambda (sym)
(let ((saved (hashq-ref saved-port-bindings sym)))
(module-set! mod sym saved)))
syms))))
port-bindings)
(set! saved-port-bindings #f)))

70
module/ice-9/textual-ports.scm Normal file
View file

@ -0,0 +1,70 @@
;;;; textual-ports.scm --- Textual I/O on ports
;;;; Copyright (C) 2016 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:
;;;
;;; Code:
(define-module (ice-9 textual-ports)
#:use-module (ice-9 ports internal)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 rdelim)
#:re-export (get-string-n!
put-char
put-string)
#:export (get-char
unget-char
unget-string
lookahead-char
get-string-n
get-string-all
get-line))
(define (get-char port)
(read-char port))
(define (lookahead-char port)
(peek-char port))
(define (unget-char port char)
(unread-char char port))
(define* (unget-string port string #:optional (start 0)
(count (- (string-length string) start)))
(unread-string (if (and (zero? start)
(= count (string-length string)))
string
(substring/shared string start (+ start count)))
port))
(define (get-line port)
(read-line port 'trim))
(define (get-string-all port)
(read-string port))
(define (get-string-n port count)
"Read up to @var{count} characters from @var{port}.
If no characters could be read before encountering the end of file,
return the end-of-file object, otherwise return a string containing
the characters read."
(let* ((s (make-string count))
(rv (get-string-n! port s 0 count)))
(cond ((eof-object? rv) rv)
((= rv count) s)
(else (substring/shared s 0 rv)))))

259
module/ice-9/threads.scm
View file

@ -26,22 +26,49 @@
;;; Commentary:
;; This module is documented in the Guile Reference Manual.
;; Briefly, one procedure is exported: `%thread-handler';
;; as well as four macros: `make-thread', `begin-thread',
;; `with-mutex' and `monitor'.
;;; Code:
(define-module (ice-9 threads)
#:use-module (ice-9 futures)
#:use-module (ice-9 match)
#:use-module (ice-9 control)
;; These bindings are marked as #:replace because when deprecated code
;; is enabled, (ice-9 deprecated) also exports these names.
;; (Referencing one of the deprecated names prints a warning directing
;; the user to these bindings.) Anyway once we can remove the
;; deprecated bindings, we should use #:export instead of #:replace
;; for these.
#:replace (call-with-new-thread
yield
cancel-thread
join-thread
thread?
make-mutex
make-recursive-mutex
lock-mutex
try-mutex
unlock-mutex
mutex?
mutex-owner
mutex-level
mutex-locked?
make-condition-variable
wait-condition-variable
signal-condition-variable
broadcast-condition-variable
condition-variable?
current-thread
all-threads
thread-exited?
total-processor-count
current-processor-count)
#:export (begin-thread
parallel
letpar
make-thread
with-mutex
monitor
parallel
letpar
par-map
par-for-each
n-par-map
@ -49,6 +76,134 @@
n-for-each-par-map
%thread-handler))
;; Note that this extension also defines %make-transcoded-port, which is
;; not exported but is used by (rnrs io ports).
(eval-when (expand eval load)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_threads"))
(define-syntax-rule (with-mutex m e0 e1 ...)
(let ((x m))
(dynamic-wind
(lambda () (lock-mutex x))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))
(define cancel-tag (make-prompt-tag "cancel"))
(define (cancel-thread thread . values)
"Asynchronously interrupt the target @var{thread} and ask it to
terminate, returning the given @var{values}. @code{dynamic-wind} post
thunks will run, but throw handlers will not. If @var{thread} has
already terminated or been signaled to terminate, this function is a
no-op."
(system-async-mark
(lambda ()
(catch #t
(lambda ()
(apply abort-to-prompt cancel-tag values))
(lambda _
(error "thread cancellation failed, throwing error instead???"))))
thread))
(define thread-join-data (make-object-property))
(define %thread-results (make-object-property))
(define* (call-with-new-thread thunk #:optional handler)
"Call @code{thunk} in a new thread and with a new dynamic state,
returning a new thread object representing the thread. The procedure
@var{thunk} is called via @code{with-continuation-barrier}.
When @var{handler} is specified, then @var{thunk} is called from within
a @code{catch} with tag @code{#t} that has @var{handler} as its handler.
This catch is established inside the continuation barrier.
Once @var{thunk} or @var{handler} returns, the return value is made the
@emph{exit value} of the thread and the thread is terminated."
(let ((cv (make-condition-variable))
(mutex (make-mutex))
(thunk (if handler
(lambda () (catch #t thunk handler))
thunk))
(thread #f))
(define (call-with-backtrace thunk)
(let ((err (current-error-port)))
(catch #t
(lambda () (%start-stack 'thread thunk))
(lambda _ (values))
(lambda (key . args)
;; Narrow by three: the dispatch-exception,
;; this thunk, and make-stack.
(let ((stack (make-stack #t 3)))
(false-if-exception
(begin
(when stack
(display-backtrace stack err))
(let ((frame (and stack (stack-ref stack 0))))
(print-exception err frame key args)))))))))
(with-mutex mutex
(%call-with-new-thread
(lambda ()
(call-with-values
(lambda ()
(call-with-prompt cancel-tag
(lambda ()
(lock-mutex mutex)
(set! thread (current-thread))
(set! (thread-join-data thread) (cons cv mutex))
(signal-condition-variable cv)
(unlock-mutex mutex)
(call-with-unblocked-asyncs
(lambda () (call-with-backtrace thunk))))
(lambda (k . args)
(apply values args))))
(lambda vals
(lock-mutex mutex)
;; Probably now you're wondering why we are going to use
;; the cond variable as the key into the thread results
;; object property. It's because there is a possibility
;; that the thread object itself ends up as part of the
;; result, and if that happens we create a cycle whereby
;; the strong reference to a thread in the value of the
;; weak-key hash table used by the object property prevents
;; the thread from ever being collected. So instead we use
;; the cv as the key. Weak-key hash tables, amirite?
(set! (%thread-results cv) vals)
(broadcast-condition-variable cv)
(unlock-mutex mutex)
(apply values vals)))))
(let lp ()
(unless thread
(wait-condition-variable cv mutex)
(lp))))
thread))
(define* (join-thread thread #:optional timeout timeoutval)
"Suspend execution of the calling thread until the target @var{thread}
terminates, unless the target @var{thread} has already terminated."
(match (thread-join-data thread)
(#f (error "foreign thread cannot be joined" thread))
((cv . mutex)
(lock-mutex mutex)
(let lp ()
(cond
((%thread-results cv)
=> (lambda (results)
(unlock-mutex mutex)
(apply values results)))
((if timeout
(wait-condition-variable cv mutex timeout)
(wait-condition-variable cv mutex))
(lp))
(else timeoutval))))))
(define* (try-mutex mutex)
"Try to lock @var{mutex}. If the mutex is already locked, return
@code{#f}. Otherwise lock the mutex and return @code{#t}."
(lock-mutex mutex 0))
;;; Macros first, so that the procedures expand correctly.
@ -58,6 +213,57 @@
(lambda () e0 e1 ...)
%thread-handler))
(define-syntax-rule (make-thread proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
%thread-handler))
(define monitor-mutex-table (make-hash-table))
(define monitor-mutex-table-mutex (make-mutex))
(define (monitor-mutex-with-id id)
(with-mutex monitor-mutex-table-mutex
(or (hashq-ref monitor-mutex-table id)
(let ((mutex (make-mutex)))
(hashq-set! monitor-mutex-table id mutex)
mutex))))
(define-syntax monitor
(lambda (stx)
(syntax-case stx ()
((_ body body* ...)
(let ((id (datum->syntax #'body (gensym))))
#`(with-mutex (monitor-mutex-with-id '#,id)
body body* ...))))))
(define (thread-handler tag . args)
(let ((n (length args))
(p (current-error-port)))
(display "In thread:" p)
(newline p)
(if (>= n 3)
(display-error #f
p
(car args)
(cadr args)
(caddr args)
(if (= n 4)
(cadddr args)
'()))
(begin
(display "uncaught throw to " p)
(display tag p)
(display ": " p)
(display args p)
(newline p)))
#f))
;;; Set system thread handler
(define %thread-handler thread-handler)
(use-modules (ice-9 futures))
(define-syntax parallel
(lambda (x)
(syntax-case x ()
@ -73,22 +279,6 @@
(lambda (v ...)
b0 b1 ...)))
(define-syntax-rule (make-thread proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
%thread-handler))
(define-syntax-rule (with-mutex m e0 e1 ...)
(let ((x m))
(dynamic-wind
(lambda () (lock-mutex x))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))
(define-syntax-rule (monitor first rest ...)
(with-mutex (make-mutex)
first rest ...))
(define (par-mapper mapper cons)
(lambda (proc . lists)
(let loop ((lists lists))
@ -190,29 +380,4 @@ of applying P-PROC on ARGLISTS."
(loop))))))
threads)))))
(define (thread-handler tag . args)
(let ((n (length args))
(p (current-error-port)))
(display "In thread:" p)
(newline p)
(if (>= n 3)
(display-error #f
p
(car args)
(cadr args)
(caddr args)
(if (= n 4)
(cadddr args)
'()))
(begin
(display "uncaught throw to " p)
(display tag p)
(display ": " p)
(display args p)
(newline p)))
#f))
;;; Set system thread handler
(define %thread-handler thread-handler)
;;; threads.scm ends here

46
module/language/bytecode.scm
View file

@ -34,34 +34,40 @@
(define (compute-instruction-arity name args)
(define (first-word-arity word)
(case word
((U8_X24) 0)
((U8_U24) 1)
((U8_L24) 1)
((U8_U8_I16) 2)
((U8_U12_U12) 2)
((U8_U8_U8_U8) 3)))
((X32) 0)
((X8_S24) 1)
((X8_F24) 1)
((X8_C24) 1)
((X8_L24) 1)
((X8_S8_I16) 2)
((X8_S12_S12) 2)
((X8_S12_C12) 2)
((X8_C12_C12) 2)
((X8_F12_F12) 2)
((X8_S8_S8_S8) 3)
((X8_S8_S8_C8) 3)
((X8_S8_C8_S8) 3)))
(define (tail-word-arity word)
(case word
((U8_U24) 2)
((U8_L24) 2)
((U8_U8_I16) 3)
((U8_U12_U12) 3)
((U8_U8_U8_U8) 4)
((U32) 1)
((C32) 1)
((I32) 1)
((A32) 1)
((B32) 0)
((A32 AU32 AS32 AF32) 1)
((B32 BF32 BS32 BU32) 0)
((N32) 1)
((S32) 1)
((R32) 1)
((L32) 1)
((LO32) 1)
((X8_U24) 1)
((X8_U12_U12) 2)
((X8_L24) 1)
((C8_C24) 2)
((B1_C7_L24) 3)
((B1_X7_S24) 2)
((B1_X7_F24) 2)
((B1_X7_C24) 2)
((B1_X7_L24) 2)
((B1_U7_L24) 3)
((B1_X31) 1)
((B1_X7_U24) 2)))
((X8_S24) 1)
((X8_F24) 1)
((X8_C24) 1)
((X8_L24) 1)))
(match args
((arg0 . args)
(fold (lambda (arg arity)

554
module/language/cps.scm
View file

@ -21,28 +21,75 @@
;;; This is the continuation-passing style (CPS) intermediate language
;;; (IL) for Guile.
;;;
;;; There are two kinds of terms in CPS: terms that bind continuations,
;;; and terms that call continuations.
;;; In CPS, a term is a labelled expression that calls a continuation.
;;; A function is a collection of terms. No term belongs to more than
;;; one function. The function is identified by the label of its entry
;;; term, and its body is composed of those terms that are reachable
;;; from the entry term. A program is a collection of functions,
;;; identified by the entry label of the entry function.
;;;
;;; $letk binds a set of mutually recursive continuations, each one an
;;; instance of $cont. A $cont declares the name of a continuation, and
;;; then contains as a subterm the particular continuation instance:
;;; $kargs for continuations that bind values, $ktail for the tail
;;; continuation, etc.
;;; Terms are themselves wrapped in continuations, which specify how
;;; predecessors may continue to them. For example, a $kargs
;;; continuation specifies that the term may be called with a specific
;;; number of values, and that those values will then be bound to
;;; lexical variables. $kreceive specifies that some number of values
;;; will be passed on the stack, as from a multiple-value return. Those
;;; values will be passed to a $kargs, if the number of values is
;;; compatible with the $kreceive's arity. $kfun is an entry point to a
;;; function, and receives arguments according to a well-known calling
;;; convention (currently, on the stack) and the stack before
;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
;;; only appears within a $kfun; it checks the incoming values for the
;;; correct arity and dispatches to a $kargs, or to the next clause.
;;; Finally, $ktail is the tail continuation for a function, and
;;; contains no term.
;;;
;;; Each continuation has a label that is unique in the program. As an
;;; implementation detail, the labels are integers, which allows us to
;;; easily sort them topologically. A program is a map from integers to
;;; continuations, where continuation 0 in the map is the entry point
;;; for the program, and is a $kfun of no arguments.
;;;
;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to
;;; pass multiple named values, etc. $continue nodes also record the source at which
;;; pass multiple named values, etc. $continue nodes also record the
;;; source location corresponding to the expression.
;;;
;;; Additionally there is $letrec, a term that binds mutually recursive
;;; functions. The contification pass will turn $letrec into $letk if
;;; it can do so. Otherwise, the closure conversion pass will desugar
;;; $letrec into an equivalent sequence of make-closure primcalls and
;;; subsequent initializations of the captured variables of the
;;; closures. You can think of $letrec as pertaining to "high CPS",
;;; whereas later passes will only see "low CPS", which does not have
;;; $letrec.
;;; As mentioned above, a $kargs continuation can bind variables, if it
;;; receives incoming values. $kfun also binds a value, corresponding
;;; to the closure being called. A traditional CPS implementation will
;;; nest terms in each other, binding them in "let" forms, ensuring that
;;; continuations are declared and bound within the scope of the values
;;; that they may use. In this way, the scope tree is a proof that
;;; variables are defined before they are used. However, this proof is
;;; conservative; it is possible for a variable to always be defined
;;; before it is used, but not to be in scope:
;;;
;;; (letrec ((k1 (lambda (v1) (k2)))
;;; (k2 (lambda () v1)))
;;; (k1 0))
;;;
;;; This example is invalid, as v1 is used outside its scope. However
;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
;;; k1:
;;;
;;; (letrec ((k1 (lambda (v1)
;;; (letrec ((k2 (lambda () v1)))
;;; (k2))))
;;; (k1 0))
;;;
;;; Because program transformation usually uses flow-based analysis,
;;; having to update the scope tree to manifestly prove a transformation
;;; that has already proven correct is needless overhead, and in the
;;; worst case can prevent optimizations from occuring. For that
;;; reason, Guile's CPS language does not nest terms. Instead, we use
;;; the invariant that definitions must dominate uses. To check the
;;; validity of a CPS program is thus more involved than checking for a
;;; well-scoped tree; you have to do flow analysis to determine a
;;; dominator tree. However the flexibility that this grants us is
;;; worth the cost of throwing away the embedded proof of the scope
;;; tree.
;;;
;;; This particular formulation of CPS was inspired by Andrew Kennedy's
;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
@ -51,51 +98,16 @@
;;; labels. All values are bound to variables using continuation calls:
;;; even constants!
;;;
;;; There are some Guile-specific quirks as well:
;;;
;;; - $kreceive represents a continuation that receives multiple values,
;;; but which truncates them to some number of required values,
;;; possibly with a rest list.
;;;
;;; - $kfun labels an entry point for a $fun (a function), and
;;; contains a $ktail representing the formal argument which is the
;;; function's continuation.
;;;
;;; - $kfun also contain a $kclause continuation, corresponding to
;;; the first case-lambda clause of the function. $kclause actually
;;; contains the clause body, and the subsequent clause (if any).
;;; This is because the $kclause logically matches or doesn't match
;;; a given set of actual arguments against a formal arity, then
;;; proceeds to a "body" continuation (which is a $kargs).
;;;
;;; That's to say that a $fun can be matched like this:
;;;
;;; (match f
;;; (($ $fun
;;; ($ $cont kfun
;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
;;; ($ $kclause arity
;;; ($ $cont kbody ($ $kargs names syms body))
;;; alternate))))
;;; #t))
;;;
;;; A $continue to ktail is in tail position. $kfun, $kclause,
;;; and $ktail will never be seen elsewhere in a CPS term.
;;;
;;; - $prompt continues to the body of the prompt, having pushed on a
;;; prompt whose handler will continue at its "handler"
;;; continuation. The continuation of the prompt is responsible for
;;; popping the prompt.
;;;
;;; In summary:
;;;
;;; - $letk, $letrec, and $continue are terms.
;;;
;;; - $cont is a continuation, containing a continuation body ($kargs,
;;; $ktail, etc).
;;;
;;; - $continue terms contain an expression ($call, $const, $fun,
;;; etc).
;;; Finally, note that there are two flavors of CPS: higher-order and
;;; first-order. By "higher-order", we mean that variables may be free
;;; across function boundaries. Higher-order CPS contains $fun and $rec
;;; expressions that declare functions in the scope of their term.
;;; Closure conversion results in first-order CPS, where closure
;;; representations have been explicitly chosen, and all variables used
;;; in a function are bound. Higher-order CPS is good for
;;; interprocedural optimizations like contification and beta reduction,
;;; while first-order CPS is better for instruction selection, register
;;; allocation, and code generation.
;;;
;;; See (language tree-il compile-cps) for details on how Tree-IL
;;; converts to CPS.
@ -104,7 +116,6 @@
(define-module (language cps)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
@ -112,37 +123,22 @@
$arity
make-$arity
;; Terms.
$letk $continue
;; Continuations.
$cont
;; Continuation bodies.
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
$continue
;; Expressions.
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt
;; First-order CPS root.
$program
;; Fresh names.
label-counter var-counter
fresh-label fresh-var
with-fresh-name-state compute-max-label-and-var
let-fresh
;; Building macros.
build-cps-term build-cps-cont build-cps-exp
rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
build-cont build-term build-exp
rewrite-cont rewrite-term rewrite-exp
;; Misc.
parse-cps unparse-cps
make-global-cont-folder make-local-cont-folder
fold-conts fold-local-conts
visit-cont-successors))
;; External representation.
parse-cps unparse-cps))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@ -174,17 +170,15 @@
;; Helper.
(define-record-type* $arity req opt rest kw allow-other-keys?)
;; Terms.
(define-cps-type $letk conts body)
(define-cps-type $continue k src exp)
;; Continuations
(define-cps-type $cont k cont)
(define-cps-type $kreceive arity k)
(define-cps-type $kargs names syms body)
(define-cps-type $kfun src meta self tail clause)
(define-cps-type $kreceive arity kbody)
(define-cps-type $kargs names syms term)
(define-cps-type $kfun src meta self ktail kclause)
(define-cps-type $ktail)
(define-cps-type $kclause arity cont alternate)
(define-cps-type $kclause arity kbody kalternate)
;; Terms.
(define-cps-type $continue k src exp)
;; Expressions.
(define-cps-type $const val)
@ -192,83 +186,53 @@
(define-cps-type $fun body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch k exp)
(define-cps-type $branch kt exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
;; The root of a higher-order CPS term is $cont containing a $kfun. The
;; root of a first-order CPS term is a $program.
(define-cps-type $program funs)
(define label-counter (make-parameter #f))
(define var-counter (make-parameter #f))
(define (fresh-label)
(let ((count (or (label-counter)
(error "fresh-label outside with-fresh-name-state"))))
(label-counter (1+ count))
count))
(define (fresh-var)
(let ((count (or (var-counter)
(error "fresh-var outside with-fresh-name-state"))))
(var-counter (1+ count))
count))
(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
(let ((label (fresh-label)) ...
(var (fresh-var)) ...)
body ...))
(define-syntax-rule (with-fresh-name-state fun body ...)
(call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
(parameterize ((label-counter (1+ max-label))
(var-counter (1+ max-var)))
body ...))))
(define-syntax build-arity
(syntax-rules (unquote)
((_ (unquote exp)) exp)
((_ (req opt rest kw allow-other-keys?))
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body
(define-syntax build-cont
(syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kreceive req rest kargs))
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
((_ ($kargs (name ...) (unquote syms) body))
(make-$kargs (list name ...) syms (build-cps-term body)))
(make-$kargs (list name ...) syms (build-term body)))
((_ ($kargs (name ...) (sym ...) body))
(make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
(make-$kargs (list name ...) (list sym ...) (build-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-cps-term body)))
((_ ($kfun src meta self tail clause))
(make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
(make-$kargs names syms (build-term body)))
((_ ($kfun src meta self ktail kclause))
(make-$kfun src meta self ktail kclause))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity cont alternate))
(make-$kclause (build-arity arity) (build-cps-cont cont)
(build-cps-cont alternate)))))
((_ ($kclause arity kbody kalternate))
(make-$kclause (build-arity arity) kbody kalternate))))
(define-syntax build-cps-cont
(syntax-rules (unquote)
((_ (unquote exp)) exp)
((_ (k cont)) (make-$cont k (build-cont-body cont)))))
(define-syntax build-term
(syntax-rules (unquote $rec $continue)
((_ (unquote exp))
exp)
((_ ($continue k src exp))
(make-$continue k src (build-exp exp)))))
(define-syntax build-cps-exp
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($fun body)) (make-$fun (build-cps-cont body)))
((_ ($fun kentry)) (make-$fun kentry))
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args))
@ -283,50 +247,19 @@
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
(define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $program $continue)
((_ (unquote exp))
exp)
((_ ($letk (unquote conts) body))
(make-$letk conts (build-cps-term body)))
((_ ($letk (cont ...) body))
(make-$letk (list (build-cps-cont cont) ...)
(build-cps-term body)))
((_ ($letk* () body))
(build-cps-term body))
((_ ($letk* (cont conts ...) body))
(build-cps-term ($letk (cont) ($letk* (conts ...) body))))
((_ ($letconst () body))
(build-cps-term body))
((_ ($letconst ((name sym val) tail ...) body))
(let-fresh (kconst) ()
(build-cps-term
($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
($continue kconst (let ((props (source-properties val)))
(and (pair? props) props))
($const val))))))
((_ ($program (unquote conts)))
(make-$program conts))
((_ ($program (cont ...)))
(make-$program (list (build-cps-cont cont) ...)))
((_ ($program conts))
(make-$program conts))
((_ ($continue k src exp))
(make-$continue k src (build-cps-exp exp)))))
(define-syntax-rule (rewrite-cps-term x (pat body) ...)
(define-syntax-rule (rewrite-cont x (pat cont) ...)
(match x
(pat (build-cps-term body)) ...))
(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
(pat (build-cont cont)) ...))
(define-syntax-rule (rewrite-term x (pat term) ...)
(match x
(pat (build-cps-cont body)) ...))
(define-syntax-rule (rewrite-cps-exp x (pat body) ...)
(pat (build-term term)) ...))
(define-syntax-rule (rewrite-exp x (pat body) ...)
(match x
(pat (build-cps-exp body)) ...))
(pat (build-exp body)) ...))
(define (parse-cps exp)
(define (src exp)
@ -334,121 +267,81 @@
(and (pair? props) props)))
(match exp
;; Continuations.
(('letconst k (name sym c) body)
(build-cps-term
($letk ((k ($kargs (name) (sym)
,(parse-cps body))))
($continue k (src exp) ($const c)))))
(('let k (name sym val) body)
(build-cps-term
($letk ((k ($kargs (name) (sym)
,(parse-cps body))))
,(parse-cps val))))
(('letk (cont ...) body)
(build-cps-term
($letk ,(map parse-cps cont) ,(parse-cps body))))
(('k sym body)
(build-cps-cont
(sym ,(parse-cps body))))
(('kreceive req rest k)
(build-cont-body ($kreceive req rest k)))
(build-cont ($kreceive req rest k)))
(('kargs names syms body)
(build-cont-body ($kargs names syms ,(parse-cps body))))
(('kfun src meta self tail clause)
(build-cont-body
($kfun (src exp) meta self ,(parse-cps tail)
,(and=> clause parse-cps))))
(build-cont ($kargs names syms ,(parse-cps body))))
(('kfun meta self ktail kclause)
(build-cont ($kfun (src exp) meta self ktail kclause)))
(('ktail)
(build-cont-body
($ktail)))
(('kclause (req opt rest kw allow-other-keys?) body)
(build-cont-body
($kclause (req opt rest kw allow-other-keys?)
,(parse-cps body)
,#f)))
(('kclause (req opt rest kw allow-other-keys?) body alternate)
(build-cont-body
($kclause (req opt rest kw allow-other-keys?)
,(parse-cps body)
,(parse-cps alternate))))
(('kseq body)
(build-cont-body ($kargs () () ,(parse-cps body))))
(build-cont ($ktail)))
(('kclause (req opt rest kw allow-other-keys?) kbody)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
(('kclause (req opt rest kw allow-other-keys?) kbody kalt)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
;; Calls.
(('continue k exp)
(build-cps-term ($continue k (src exp) ,(parse-cps exp))))
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('unspecified)
(build-exp ($const *unspecified*)))
(('const exp)
(build-cps-exp ($const exp)))
(build-exp ($const exp)))
(('prim name)
(build-cps-exp ($prim name)))
(('fun body)
(build-cps-exp ($fun ,(parse-cps body))))
(build-exp ($prim name)))
(('fun kbody)
(build-exp ($fun kbody)))
(('closure k nfree)
(build-cps-exp ($closure k nfree)))
(build-exp ($closure k nfree)))
(('rec (name sym fun) ...)
(build-cps-exp ($rec name sym (map parse-cps fun))))
(('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont))))
(build-exp ($rec name sym (map parse-cps fun))))
(('call proc arg ...)
(build-cps-exp ($call proc arg)))
(build-exp ($call proc arg)))
(('callk k proc arg ...)
(build-cps-exp ($callk k proc arg)))
(build-exp ($callk k proc arg)))
(('primcall name arg ...)
(build-cps-exp ($primcall name arg)))
(build-exp ($primcall name arg)))
(('branch k exp)
(build-cps-exp ($branch k ,(parse-cps exp))))
(build-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
(build-cps-exp ($values arg)))
(build-exp ($values arg)))
(('prompt escape? tag handler)
(build-cps-exp ($prompt escape? tag handler)))
(build-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
(define (unparse-cps exp)
(match exp
;; Continuations.
(($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
($ $continue k src ($ $const c)))
`(letconst ,k (,name ,sym ,c)
,(unparse-cps body)))
(($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
`(let ,k (,name ,sym ,(unparse-cps val))
,(unparse-cps body)))
(($ $letk conts body)
`(letk ,(map unparse-cps conts) ,(unparse-cps body)))
(($ $cont sym body)
`(k ,sym ,(unparse-cps body)))
(($ $kreceive ($ $arity req () rest '() #f) k)
(($ $kreceive ($ $arity req () rest () #f) k)
`(kreceive ,req ,rest ,k))
(($ $kargs () () body)
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
(($ $kfun src meta self tail clause)
`(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
(($ $kfun src meta self ktail kclause)
`(kfun ,meta ,self ,ktail ,kclause))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
. ,(if alternate (list (unparse-cps alternate)) '())))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
. ,(if kalternate (list kalternate) '())))
;; Calls.
(($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $const val)
`(const ,val))
(if (unspecified? val)
'(unspecified)
`(const ,val)))
(($ $prim name)
`(prim ,name))
(($ $fun body)
`(fun ,(unparse-cps body)))
(($ $fun kbody)
`(fun ,kbody))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $rec names syms funs)
`(rec ,@(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
names syms funs)))
(($ $program conts)
`(program ,(map unparse-cps conts)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
@ -463,158 +356,3 @@
`(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))
(define-syntax-rule (make-global-cont-folder seed ...)
(lambda (proc cont seed ...)
(define (cont-folder cont seed ...)
(match cont
(($ $cont k cont)
(let-values (((seed ...) (proc k cont seed ...)))
(match cont
(($ $kargs names syms body)
(term-folder body seed ...))
(($ $kfun src meta self tail clause)
(let-values (((seed ...) (cont-folder tail seed ...)))
(if clause
(cont-folder clause seed ...)
(values seed ...))))
(($ $kclause arity body alternate)
(let-values (((seed ...) (cont-folder body seed ...)))
(if alternate
(cont-folder alternate seed ...)
(values seed ...))))
(_ (values seed ...)))))))
(define (fun-folder fun seed ...)
(match fun
(($ $fun body)
(cont-folder body seed ...))))
(define (term-folder term seed ...)
(match term
(($ $letk conts body)
(let-values (((seed ...) (term-folder body seed ...)))
(let lp ((conts conts) (seed seed) ...)
(if (null? conts)
(values seed ...)
(let-values (((seed ...) (cont-folder (car conts) seed ...)))
(lp (cdr conts) seed ...))))))
(($ $continue k src exp)
(match exp
(($ $fun) (fun-folder exp seed ...))
(($ $rec names syms funs)
(let lp ((funs funs) (seed seed) ...)
(if (null? funs)
(values seed ...)
(let-values (((seed ...) (fun-folder (car funs) seed ...)))
(lp (cdr funs) seed ...)))))
(_ (values seed ...))))))
(cont-folder cont seed ...)))
(define-syntax-rule (make-local-cont-folder seed ...)
(lambda (proc cont seed ...)
(define (cont-folder cont seed ...)
(match cont
(($ $cont k (and cont ($ $kargs names syms body)))
(let-values (((seed ...) (proc k cont seed ...)))
(term-folder body seed ...)))
(($ $cont k cont)
(proc k cont seed ...))))
(define (term-folder term seed ...)
(match term
(($ $letk conts body)
(let-values (((seed ...) (term-folder body seed ...)))
(let lp ((conts conts) (seed seed) ...)
(match conts
(() (values seed ...))
((cont) (cont-folder cont seed ...))
((cont . conts)
(let-values (((seed ...) (cont-folder cont seed ...)))
(lp conts seed ...)))))))
(_ (values seed ...))))
(define (clause-folder clause seed ...)
(match clause
(($ $cont k (and cont ($ $kclause arity body alternate)))
(let-values (((seed ...) (proc k cont seed ...)))
(if alternate
(let-values (((seed ...) (cont-folder body seed ...)))
(clause-folder alternate seed ...))
(cont-folder body seed ...))))))
(match cont
(($ $cont k (and cont ($ $kfun src meta self tail clause)))
(let*-values (((seed ...) (proc k cont seed ...))
((seed ...) (if clause
(clause-folder clause seed ...)
(values seed ...))))
(cont-folder tail seed ...))))))
(define (compute-max-label-and-var fun)
(match fun
(($ $cont)
((make-global-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars body)
(fold max max-var vars))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
fun -1 -1))
(($ $program conts)
(define (fold/2 proc in s0 s1)
(if (null? in)
(values s0 s1)
(let-values (((s0 s1) (proc (car in) s0 s1)))
(fold/2 proc (cdr in) s0 s1))))
(let lp ((conts conts) (max-label -1) (max-var -1))
(if (null? conts)
(values max-label max-var)
(call-with-values (lambda ()
((make-local-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars body)
(fold max max-var vars))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
(car conts) max-label max-var))
(lambda (max-label max-var)
(lp (cdr conts) max-label max-var))))))))
(define (fold-conts proc seed fun)
((make-global-cont-folder seed) proc fun seed))
(define (fold-local-conts proc seed fun)
((make-local-cont-folder seed) proc fun seed))
(define (visit-cont-successors proc cont)
(match cont
(($ $kargs names syms body)
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (proc k handler))
(($ $branch kt) (proc k kt))
(_ (proc k)))))))
(($ $kreceive arity k) (proc k))
(($ $kclause arity ($ $cont kbody) #f) (proc kbody))
(($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
(($ $kfun src meta self tail ($ $cont clause)) (proc clause))
(($ $kfun src meta self tail #f) (proc))
(($ $ktail) (proc))))

1231
module/language/cps/closure-conversion.scm
View file

File diff suppressed because it is too large Load diff

688
module/language/cps/compile-bytecode.scm
View file

@ -27,88 +27,72 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps constructors)
#:use-module (language cps cse)
#:use-module (language cps dce)
#:use-module (language cps dfg)
#:use-module (language cps elide-values)
#:use-module (language cps primitives)
#:use-module (language cps prune-bailouts)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps slot-allocation)
#:use-module (language cps utils)
#:use-module (language cps closure-conversion)
#:use-module (language cps handle-interrupts)
#:use-module (language cps optimize)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
#:use-module (language cps self-references)
#:use-module (language cps simplify)
#:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps type-fold)
#:use-module (language cps split-rec)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
#:export (compile-bytecode))
;; TODO: Local var names.
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (optimize exp opts)
(define (run-pass! pass kw default)
(set! exp
(if (kw-arg-ref opts kw default)
(pass exp)
exp)))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
;; The first DCE pass is mainly to eliminate functions that aren't
;; called. The last is mainly to eliminate rest parameters that
;; aren't used, and thus shouldn't be consed.
(define (intmap-select map set)
(persistent-intmap
(intset-fold
(lambda (k out)
(intmap-add! out k (intmap-ref map k)))
set
empty-intmap)))
;; This series of assignments to `env' used to be a series of let*
;; bindings of `env', as you would imagine. In compiled code this is
;; fine because the compiler is able to allocate all let*-bound
;; variable to the same slot, which also means that the garbage
;; collector doesn't have to retain so many copies of the term being
;; optimized. However during bootstrap, the interpreter doesn't do
;; this optimization, leading to excessive data retention as the terms
;; are rewritten. To marginally improve bootstrap memory usage, here
;; we use set! instead. The compiler should produce the same code in
;; any case, though currently it does not because it doesn't do escape
;; analysis on the box created for the set!.
;; Any $values expression that continues to a $kargs and causes no
;; shuffles is a forwarding label.
(define (compute-forwarding-labels cps allocation)
(fixpoint
(lambda (forwarding-map)
(intmap-fold (lambda (label target forwarding-map)
(let ((new-target (intmap-ref forwarding-map target
(lambda (target) target))))
(if (eqv? target new-target)
forwarding-map
(intmap-replace forwarding-map label new-target))))
forwarding-map forwarding-map))
(intmap-fold (lambda (label cont forwarding-labels)
(match cont
(($ $kargs _ _ ($ $continue k _ ($ $values)))
(match (lookup-parallel-moves label allocation)
(()
(match (intmap-ref cps k)
(($ $ktail) forwarding-labels)
(_ (intmap-add forwarding-labels label k))))
(_ forwarding-labels)))
(_ forwarding-labels)))
cps empty-intmap)))
(run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
;; The prune-top-level-scopes pass doesn't work if CSE has run
;; beforehand. Since hopefully we will be able to just remove all the
;; old CPS stuff, let's just disable the pass for now.
;; (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t)
(run-pass! simplify #:simplify? #t)
(run-pass! contify #:contify? #t)
(run-pass! inline-constructors #:inline-constructors? #t)
(run-pass! specialize-primcalls #:specialize-primcalls? #t)
(run-pass! elide-values #:elide-values? #t)
(run-pass! prune-bailouts #:prune-bailouts? #t)
(run-pass! eliminate-common-subexpressions #:cse? #t)
(run-pass! type-fold #:type-fold? #t)
(run-pass! resolve-self-references #:resolve-self-references? #t)
(run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
(run-pass! simplify #:simplify? #t)
(define (compile-function cps asm)
(let* ((allocation (allocate-slots cps))
(forwarding-labels (compute-forwarding-labels cps allocation))
(frame-size (lookup-nlocals allocation)))
(define (forward-label k)
(intmap-ref forwarding-labels k (lambda (k) k)))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
;; * Loop peeling. Unrolls the first round through a loop if the
;; loop has effects that CSE can work on. Requires effects
;; analysis. When run before CSE, loop peeling is the equivalent
;; of loop-invariant code motion (LICM).
(define (elide-cont? label)
(match (intmap-ref forwarding-labels label (lambda (_) #f))
(#f #f)
(target (not (eqv? label target)))))
exp)
(define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f))
(allocation (allocate-slots f dfg)))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
@ -118,110 +102,12 @@
(define (constant sym)
(lookup-constant-value sym allocation))
(define (from-sp var)
(- frame-size 1 var))
(define (maybe-mov dst src)
(unless (= dst src)
(emit-mov asm dst src)))
(define (maybe-load-constant slot src)
(call-with-values (lambda ()
(lookup-maybe-constant-value src allocation))
(lambda (has-const? val)
(and has-const?
(begin
(emit-load-constant asm slot val)
#t)))))
(define (compile-entry)
(let ((label (dfg-min-label dfg)))
(match (lookup-cont label dfg)
(($ $kfun src meta self tail clause)
(when src
(emit-source asm src))
(emit-begin-program asm label meta)
(compile-clause (1+ label))
(emit-end-program asm)))))
(define (compile-clause label)
(match (lookup-cont label dfg)
(($ $kclause ($ $arity req opt rest kw allow-other-keys?)
body alternate)
(let* ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw))
(nlocals (lookup-nlocals label allocation)))
(emit-label asm label)
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
nlocals
(match alternate (#f #f) (($ $cont alt) alt)))
(let ((next (compile-body (1+ label) nlocals)))
(emit-end-arity asm)
(match alternate
(($ $cont alt)
(unless (eq? next alt)
(error "unexpected k" alt))
(compile-clause next))
(#f
(unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
(error "unexpected end of clauses")))))))))
(define (compile-body label nlocals)
(let compile-cont ((label label))
(if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
label
(match (lookup-cont label dfg)
(($ $kclause) label)
(($ $kargs names vars term)
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
(when slot
(emit-definition asm name slot))))
names vars)
(let find-exp ((term term))
(match term
(($ $letk conts term)
(find-exp term))
(($ $continue k src exp)
(when src
(emit-source asm src))
(compile-expression label k exp nlocals)
(compile-cont (1+ label))))))
(_
(emit-label asm label)
(compile-cont (1+ label)))))))
(define (compile-expression label k exp nlocals)
(let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump)
(unless fallthrough?
(emit-br asm k)))
(match (lookup-cont k dfg)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
(let ((dst (maybe-slot sym)))
(when dst
(compile-value label exp dst nlocals)))
(maybe-emit-jump))
(($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp kt k (1+ label)))
(_
(compile-effect label exp k nlocals)
(maybe-emit-jump))))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
(match (lookup-cont kargs dfg)
(($ $kargs names (_ ... rest)) rest)))
nlocals)
(unless (and fallthrough? (= kargs (1+ k)))
(emit-br asm kargs))))))
(emit-mov asm (from-sp dst) (from-sp src))))
(define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
@ -229,215 +115,308 @@
(match exp
(($ $call proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length args))))
(($ $callk k proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
(($ $values (arg))
(if (maybe-slot arg)
(emit-return asm (slot arg))
(begin
(emit-load-constant asm 1 (constant arg))
(emit-return asm 1))))
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-reset-frame asm (1+ (length args)))
(emit-return-values asm))
(($ $primcall 'return (arg))
(emit-return asm (slot arg)))))
(emit-return-values asm (1+ (length args))))))
(define (compile-value label exp dst nlocals)
(define (compile-value label exp dst)
(match exp
(($ $values (arg))
(or (maybe-load-constant dst arg)
(maybe-mov dst (slot arg))))
(maybe-mov dst (slot arg)))
(($ $const exp)
(emit-load-constant asm dst exp))
(emit-load-constant asm (from-sp dst) exp))
(($ $closure k 0)
(emit-load-static-procedure asm dst k))
(emit-load-static-procedure asm (from-sp dst) k))
(($ $closure k nfree)
(emit-make-closure asm dst k nfree))
(emit-make-closure asm (from-sp dst) k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(emit-current-module asm (from-sp dst)))
(($ $primcall 'current-thread)
(emit-current-thread asm (from-sp dst)))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
(emit-cached-toplevel-box asm (from-sp dst)
(constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name)
(emit-cached-module-box asm (from-sp dst)
(constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'define! (sym))
(emit-define! asm (from-sp dst) (from-sp (slot sym))))
(($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name)))
(emit-resolve asm (from-sp dst) (constant bound?)
(from-sp (slot name))))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
(emit-free-ref asm (from-sp dst) (from-sp (slot closure))
(constant idx)))
(($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index)))
(emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
(from-sp (slot index))))
(($ $primcall 'make-vector (length init))
(emit-make-vector asm dst (slot length) (slot init)))
(emit-make-vector asm (from-sp dst) (from-sp (slot length))
(from-sp (slot init))))
(($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init)))
(emit-make-vector/immediate asm (from-sp dst) (constant length)
(from-sp (slot init))))
(($ $primcall 'vector-ref/immediate (vector index))
(emit-vector-ref/immediate asm dst (slot vector) (constant index)))
(emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector))
(constant index)))
(($ $primcall 'allocate-struct (vtable nfields))
(emit-allocate-struct asm dst (slot vtable) (slot nfields)))
(emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
(from-sp (slot nfields))))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
(emit-allocate-struct/immediate asm (from-sp dst)
(from-sp (slot vtable))
(constant nfields)))
(($ $primcall 'struct-ref (struct n))
(emit-struct-ref asm dst (slot struct) (slot n)))
(emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
(from-sp (slot n))))
(($ $primcall 'struct-ref/immediate (struct n))
(emit-struct-ref/immediate asm dst (slot struct) (constant n)))
(emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
(constant n)))
(($ $primcall 'char->integer (src))
(emit-char->integer asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'integer->char (src))
(emit-integer->char asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'add/immediate (x y))
(emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
(($ $primcall 'sub/immediate (x y))
(emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
(($ $primcall 'uadd/immediate (x y))
(emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
(($ $primcall 'usub/immediate (x y))
(emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
(($ $primcall 'umul/immediate (x y))
(emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
(($ $primcall 'ursh/immediate (x y))
(emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
(($ $primcall 'ulsh/immediate (x y))
(emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
(constant y)))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name)))
(emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'scm->f64 (src))
(emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-f64 (src))
(emit-load-f64 asm (from-sp dst) (constant src)))
(($ $primcall 'f64->scm (src))
(emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64 (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64/truncate (src))
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-u64 (src))
(emit-load-u64 asm (from-sp dst) (constant src)))
(($ $primcall 'u64->scm (src))
(emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->s64 (src))
(emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-s64 (src))
(emit-load-s64 asm (from-sp dst) (constant src)))
(($ $primcall 's64->scm (src))
(emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'bv-length (bv))
(emit-bv-length asm (from-sp dst) (from-sp (slot bv))))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
(emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s8-ref (bv idx))
(emit-bv-s8-ref asm dst (slot bv) (slot idx)))
(emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
(emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
(emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
(emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
(emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
(emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
(emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
(from-sp (slot idx))))
(($ $primcall 'make-atomic-box (init))
(emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
(($ $primcall 'atomic-box-ref (box))
(emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
(($ $primcall 'atomic-box-swap! (box val))
(emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
(from-sp (slot val))))
(($ $primcall 'atomic-box-compare-and-swap! (box expected desired))
(emit-atomic-box-compare-and-swap!
asm (from-sp dst) (from-sp (slot box))
(from-sp (slot expected)) (from-sp (slot desired))))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args))))))))
(emit-text asm `((,inst ,(from-sp dst)
,@(map (compose from-sp slot) args))))))))
(define (compile-effect label exp k nlocals)
(define (compile-effect label exp k)
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (lookup-cont handler dfg)
(match (intmap-ref cps handler)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot handler allocation)))
(emit-prompt asm (slot tag) escape? proc-slot receive-args)
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (from-sp (slot tag)) escape? proc-slot
receive-args)
(emit-br asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (lookup-cont khandler-body dfg)
(match (intmap-ref cps 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)))
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm nlocals)
(emit-br asm khandler-body)))))
(emit-reset-frame asm frame-size)
(emit-br asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope)))
(emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
(emit-free-set! asm (slot closure) (slot value) (constant idx)))
(emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
(constant idx)))
(($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value)))
(emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
(emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
(from-sp (slot value))))
(($ $primcall 'struct-set!/immediate (struct index value))
(emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
(emit-struct-set!/immediate asm (from-sp (slot struct))
(constant index) (from-sp (slot value))))
(($ $primcall 'vector-set! (vector index value))
(emit-vector-set! asm (slot vector) (slot index) (slot value)))
(emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
(from-sp (slot value))))
(($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index)
(slot value)))
(emit-vector-set!/immediate asm (from-sp (slot vector))
(constant index) (from-sp (slot value))))
(($ $primcall 'string-set! (string index char))
(emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
(from-sp (slot char))))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value)))
(emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'push-dynamic-state (state))
(emit-push-dynamic-state asm (from-sp (slot state))))
(($ $primcall 'pop-dynamic-state ())
(emit-pop-dynamic-state asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
(emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s8-set! (bv idx val))
(emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
(from-sp (slot val))))
(($ $primcall 'unwind ())
(emit-unwind asm))))
(emit-unwind asm))
(($ $primcall 'fluid-set! (fluid value))
(emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value))))
(($ $primcall 'atomic-box-set! (box val))
(emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
(($ $primcall 'handle-interrupts ())
(emit-handle-interrupts asm))))
(define (compile-values label exp syms)
(match exp
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant (map slot syms) args))))
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label)
(define (prefer-true?)
(if (< (max kt kf) label)
;; Two backwards branches. Prefer
;; the nearest.
(> kt kf)
;; Otherwise prefer a backwards
;; branch or a near jump.
(< kt kf)))
(define (unary op sym)
(cond
((eq? kt next-label)
(op asm (slot sym) #t kf))
(op asm (from-sp (slot sym)) #t kf))
((eq? kf next-label)
(op asm (from-sp (slot sym)) #f kt))
(else
(op asm (slot sym) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(let ((invert? (not (prefer-true?))))
(op asm (from-sp (slot sym)) invert? (if invert? kf kt))
(emit-br asm (if invert? kt kf))))))
(define (binary op a b)
(cond
((eq? kt next-label)
(op asm (slot a) (slot b) #t kf))
(op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
((eq? kf next-label)
(op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
(else
(op asm (slot a) (slot b) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(let ((invert? (not (prefer-true?))))
(op asm (from-sp (slot a)) (from-sp (slot b)) invert?
(if invert? kf kt))
(emit-br asm (if invert? kt kf))))))
(match exp
(($ $values (sym))
(call-with-values (lambda ()
(lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(if has-const?
(if val
(unless (eq? kt next-label)
(emit-br asm kt))
(unless (eq? kf next-label)
(emit-br asm kf)))
(unary emit-br-if-true sym)))))
(($ $values (sym)) (unary emit-br-if-true sym))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
@ -455,26 +434,38 @@
;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(($ $primcall '< (a b)) (binary emit-br-if-< a b))
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(($ $primcall 'u64-< (a b)) (binary emit-br-if-u64-< a b))
(($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b))
(($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b))
(($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a))
(($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a))
(($ $primcall 'u64-<-scm (a b)) (binary emit-br-if-u64-<-scm a b))
(($ $primcall 'u64-<=-scm (a b)) (binary emit-br-if-u64-<=-scm a b))
(($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b))
(($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b))
(($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))
(($ $primcall 'f64-< (a b)) (binary emit-br-if-f64-< a b))
(($ $primcall 'f64-<= (a b)) (binary emit-br-if-f64-<= a b))
(($ $primcall 'f64-= (a b)) (binary emit-br-if-f64-= a b))
(($ $primcall 'f64->= (a b)) (binary emit-br-if-f64->= a b))
(($ $primcall 'f64-> (a b)) (binary emit-br-if-f64-> a b))))
(define (compile-trunc label k exp nreq rest-var nlocals)
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(emit-slot-map asm proc-slot (lookup-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
@ -484,16 +475,16 @@
;; The usual case: one required live return value, ignoring
;; any additional values.
=> (lambda (dst)
(emit-receive asm dst proc-slot nlocals)))
(emit-receive asm dst proc-slot frame-size)))
(else
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(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)))
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm nlocals)))))
(emit-reset-frame asm frame-size)))))
(match exp
(($ $call proc args)
(do-call proc args
@ -504,28 +495,115 @@
(lambda (asm proc-slot nargs)
(emit-call-label asm proc-slot nargs k))))))
(match f
(($ $cont k ($ $kfun src meta self tail clause))
(compile-entry)))))
(define (skip-elided-conts label)
(if (elide-cont? label)
(skip-elided-conts (1+ label))
label))
(define (compile-bytecode exp env opts)
;; See comment in `optimize' about the use of set!.
(define (compile-expression label k exp)
(let* ((forwarded-k (forward-label k))
(fallthrough? (= forwarded-k (skip-elided-conts (1+ label)))))
(define (maybe-emit-jump)
(unless fallthrough?
(emit-br asm forwarded-k)))
(match (intmap-ref cps k)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
(let ((dst (maybe-slot sym)))
(when dst
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp (forward-label kt) forwarded-k
(skip-elided-conts (1+ label))))
(_
(compile-effect label exp k)
(maybe-emit-jump))))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
(match (intmap-ref cps kargs)
(($ $kargs names (_ ... rest)) rest))))
(let* ((kargs (forward-label kargs))
(fallthrough? (and fallthrough?
(= kargs (skip-elided-conts (1+ k))))))
(unless fallthrough?
(emit-br asm kargs)))))))
;; Since CPS2's optimization pass replaces CPS and uses less memory,
;; we disable the optimization pass for now. We'll remove it once
;; we're sure.
;;
;; (set! exp (optimize exp opts))
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
(when src
(emit-source asm src))
(emit-begin-program asm label meta))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)
(_ #f)))
(kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw)))
(unless first?
(emit-end-arity asm))
(emit-label asm label)
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt)
;; All arities define a closure binding in slot 0.
(emit-definition asm 'closure 0 'scm)
;; Usually we just fall through, but it could be the body is
;; contified into another clause.
(let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label)))
(emit-br asm body)))))
(($ $kargs names vars ($ $continue k src exp))
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
(when slot
(let ((repr (lookup-representation var allocation)))
(emit-definition asm name slot repr)))))
names vars)
(when src
(emit-source asm src))
(unless (elide-cont? label)
(compile-expression label k exp)))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)
(emit-end-arity asm)
(emit-end-program asm))))
(set! exp (convert-closures exp))
;; first-order optimization should go here
(set! exp (reify-primitives exp))
(set! exp (renumber exp))
(let* ((asm (make-assembler)))
(match exp
(($ $program funs)
(for-each (lambda (fun) (compile-fun fun asm))
funs)))
(intmap-for-each compile-cont cps)))
(define (emit-bytecode exp env opts)
(let ((asm (make-assembler)))
(intmap-for-each (lambda (kfun body)
(compile-function (intmap-select exp body) asm))
(compute-reachable-functions exp 0))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
(define (lower-cps exp opts)
;; FIXME: For now the closure conversion pass relies on $rec instances
;; being separated into SCCs. We should fix this to not be the case,
;; and instead move the split-rec pass back to
;; optimize-higher-order-cps.
(set! exp (split-rec exp))
(set! exp (optimize-higher-order-cps exp opts))
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
(set! exp (add-handle-interrupts exp))
(renumber exp))
(define (compile-bytecode exp env opts)
(set! exp (lower-cps exp opts))
(emit-bytecode exp env opts))

146
module/language/cps/constructors.scm
View file

@ -25,80 +25,82 @@
(define-module (language cps constructors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:export (inline-constructors))
(define (inline-constructors* fun)
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $continue k src ($ $primcall 'list args))
,(let-fresh (kvalues) (val)
(build-cps-term
($letk ((kvalues ($kargs ('val) (val)
($continue k src
($primcall 'values (val))))))
,(let lp ((args args) (k kvalues))
(match args
(()
(build-cps-term
($continue k src ($const '()))))
((arg . args)
(let-fresh (ktail) (tail)
(build-cps-term
($letk ((ktail ($kargs ('tail) (tail)
($continue k src
($primcall 'cons (arg tail))))))
,(lp args ktail)))))))))))
(($ $continue k src ($ $primcall 'vector args))
,(let-fresh (kalloc) (vec len init)
(define (initialize args n)
(match args
(()
(build-cps-term
($continue k src ($primcall 'values (vec)))))
((arg . args)
(let-fresh (knext) (idx)
(build-cps-term
($letk ((knext ($kargs () ()
,(initialize args (1+ n)))))
($letconst (('idx idx n))
($continue knext src
($primcall 'vector-set! (vec idx arg))))))))))
(build-cps-term
($letk ((kalloc ($kargs ('vec) (vec)
,(initialize args 0))))
($letconst (('len len (length args))
('init init #f))
($continue kalloc src
($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue)
,term)))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(inline-constructors* body)))))
(define (inline-list out k src args)
(define (build-list out args k)
(match args
(()
(with-cps out
(build-term ($continue k src ($const '())))))
((arg . args)
(with-cps out
(letv tail)
(letk ktail ($kargs ('tail) (tail)
($continue k src
($primcall 'cons (arg tail)))))
($ (build-list args ktail))))))
(with-cps out
(letv val)
(letk kvalues ($kargs ('val) (val)
($continue k src
($primcall 'values (val)))))
($ (build-list args kvalues))))
(visit-cont fun))
(define (inline-vector out k src args)
(define (initialize out vec args n)
(match args
(()
(with-cps out
(build-term ($continue k src ($primcall 'values (vec))))))
((arg . args)
(with-cps out
(let$ next (initialize vec args (1+ n)))
(letk knext ($kargs () () ,next))
(letv u64)
(letk kunbox ($kargs ('idx) (u64)
($continue knext src
($primcall 'vector-set! (vec u64 arg)))))
($ (with-cps-constants ((idx n))
(build-term ($continue kunbox src
($primcall 'scm->u64 (idx))))))))))
(with-cps out
(letv vec)
(let$ body (initialize vec args 0))
(letk kalloc ($kargs ('vec) (vec) ,body))
($ (with-cps-constants ((len (length args))
(init #f))
(letv u64)
(letk kunbox ($kargs ('len) (u64)
($continue kalloc src
($primcall 'make-vector (u64 init)))))
(build-term ($continue kunbox src
($primcall 'scm->u64 (len))))))))
(define (inline-constructors fun)
(with-fresh-name-state fun
(inline-constructors* fun)))
(define (find-constructor-inliner name)
(match name
('list inline-list)
('vector inline-vector)
(_ #f)))
(define (inline-constructors conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((inline (find-constructor-inliner name)))
(if inline
(call-with-values (lambda () (inline out k src args))
(lambda (out term)
(intmap-replace! out label
(build-cont ($kargs names vars ,term)))))
out)))
(_ out)))
conts
conts))))

760
module/language/cps/contification.scm
View file

@ -30,385 +30,419 @@
(define-module (language cps contification)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (concatenate filter-map))
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-11)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps primitives)
#:use-module (language bytecode)
#:use-module (language cps renumber)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (contify))
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
(scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
(cont-splices (make-hash-table)))
(define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail)
(set! cont-substs (acons old-tail new-tail cont-substs)))
(define (splice-conts! scope conts)
(for-each (match-lambda
(($ $cont k) (hashq-set! scope-table k scope)))
conts)
(hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '()))))
(define (compute-singly-referenced-labels conts)
"Compute the set of labels in CONTS that have exactly one
predecessor."
(define (add-ref label cont single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match cont
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(#f k)
(k (lookup-return-cont k))))
(define (compute-functions conts)
"Compute a map from $kfun label to bound variable names for all
functions in CONTS. Functions have two bound variable names: their self
binding, and the name they are given in their continuation. If their
continuation has more than one predecessor, then the bound variable name
doesn't uniquely identify the function, so we exclude that function from
the set."
(define (function-self label)
(match (intmap-ref conts label)
(($ $kfun src meta self) self)))
(let ((single (compute-singly-referenced-labels conts)))
(intmap-fold (lambda (label cont functions)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
(if (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs (name) (var))
(intmap-add functions kfun
(intset var (function-self kfun)))))
functions))
(($ $kargs _ _ ($ $continue k src
($ $rec _ vars (($ $fun kfuns) ...))))
(if (intset-ref single k)
(fold (lambda (var kfun functions)
(intmap-add functions kfun
(intset var (function-self kfun))))
functions vars kfuns)
functions))
(_ functions)))
conts
empty-intmap)))
;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable.
(define (bound-symbol k)
(match (lookup-cont k dfg)
(($ $kargs (_) (sym))
(match (lookup-predecessors k dfg)
((_)
;; K has one predecessor, the one that defined SYM.
sym)
(_ #f)))
(_ #f)))
(define (compute-arities conts functions)
"Given the map FUNCTIONS whose keys are $kfun labels, return a map
from label to arities."
(define (clause-arities clause)
(if clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(cons arity (clause-arities alt))))
'()))
(intmap-map (lambda (label vars)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(clause-arities clause))))
functions))
(define (extract-arities clause)
(match clause
(($ $cont _ ($ $kclause arity body alternate))
(cons arity (extract-arities alternate)))
(#f '())))
(define (extract-bodies clause)
(match clause
(($ $cont _ ($ $kclause arity body alternate))
(cons body (extract-bodies alternate)))
(#f '())))
;; For now, we don't contify functions with optional, keyword, or rest
;; arguments.
(define (contifiable-arity? arity)
(match arity
(($ $arity req () #f () aok?)
#t)
(_
#f)))
(define (contify-fun term-k sym self tail arities bodies)
(contify-funs term-k
(list sym) (list self) (list tail)
(list arities) (list bodies)))
(define (arity-matches? arity nargs)
(match arity
(($ $arity req () #f () aok?)
(= nargs (length req)))
(_
#f)))
;; Given a set of mutually recursive functions bound to local
;; variables SYMS, with self symbols SELFS, tail continuations
;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
;; contify them if we can prove that they all return to the same
;; continuation. Returns a true value on success, and false
;; otherwise.
(define (contify-funs term-k syms selfs tails arities bodies)
(define (unused? sym)
(null? (lookup-uses sym dfg)))
;; Are the given args compatible with any of the arities?
(define (applicable? proc args)
(let lp ((arities (assq-ref (map cons syms arities) proc)))
(match arities
((($ $arity req () #f () #f) . arities)
(or (= (length args) (length req))
(lp arities)))
;; If we reached the end of the arities, fail. Also fail if
;; the next arity in the list has optional, keyword, or rest
;; arguments.
(_ #f))))
;; If the use of PROC in continuation USE is a call to PROC that
;; is compatible with one of the procedure's arities, return the
;; target continuation. Otherwise return #f.
(define (call-target use proc)
(match (find-call (lookup-cont use dfg))
(($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
;; Converge more quickly by resolving already-contified
;; call targets.
(lookup-return-cont k)))
(_ #f)))
;; If this set of functions is always called with one
;; continuation, not counting tail calls between the functions,
;; return that continuation.
(define (find-common-continuation)
(let visit-syms ((syms syms) (k #f))
(match syms
(() k)
((sym . syms)
(let visit-uses ((uses (lookup-uses sym dfg)) (k k))
(match uses
(() (visit-syms syms k))
((use . uses)
(and=> (call-target use sym)
(lambda (k*)
(cond
((memq k* tails) (visit-uses uses k))
((not k) (visit-uses uses k*))
((eq? k k*) (visit-uses uses k))
(else #f)))))))))))
;; Given that the functions are called with the common
;; continuation K, determine the scope at which to contify the
;; functions. If K is in scope in the term, we go ahead and
;; contify them there. Otherwise the scope is inside the letrec
;; body, and so choose the scope in which the continuation is
;; defined, whose free variables are a superset of the free
;; variables of the functions.
;;
;; There is some slight trickiness here. Call-target already uses
;; the information we compute within this pass. Previous
;; contifications may cause functions to be contified not at their
;; point of definition but at their point of non-recursive use.
;; That will cause the scope nesting to change. (It may
;; effectively push a function deeper down the tree -- the second
;; case above, a call within the letrec body.) What if we contify
;; to the tail of a previously contified function? We have to
;; track what the new scope tree will be when asking whether K
;; will be bound in TERM-K's scope, not the scope tree that
;; existed when we started the pass.
;;
;; FIXME: Does this choose the right scope for contified let-bound
;; functions?
(define (find-contification-scope k)
(define (scope-contains? scope k)
(let ((k-scope (or (hashq-ref scope-table k)
(let ((k-scope (lookup-block-scope k dfg)))
(hashq-set! scope-table k k-scope)
k-scope))))
(or (eq? scope k-scope)
(and k-scope (scope-contains? scope k-scope)))))
;; Find the scope of K.
(define (continuation-scope k)
(or (hashq-ref scope-table k)
(let ((scope (lookup-block-scope k dfg)))
(hashq-set! scope-table k scope)
scope)))
(let ((k-scope (continuation-scope k)))
(if (scope-contains? k-scope term-k)
term-k
(match (lookup-cont k-scope dfg)
(($ $kfun src meta self tail clause)
;; K is the tail of some function. If that function
;; has just one clause, return that clause. Otherwise
;; bail.
(match clause
(($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
kargs)
(_ #f)))
(_ k-scope)))))
;; We are going to contify. Mark all SYMs for replacement in
;; calls, and mark the tail continuations for replacement by K.
;; Arrange for the continuations to be spliced into SCOPE.
(define (enqueue-contification! k scope)
(for-each (lambda (sym tail arities bodies)
(match bodies
((($ $cont body-k) ...)
(subst-call! sym arities body-k)))
(subst-return! tail k))
syms tails arities bodies)
(splice-conts! scope (concatenate bodies))
#t)
;; "Call me maybe"
(and (and-map unused? selfs)
(and=> (find-common-continuation)
(lambda (k)
(and=> (find-contification-scope k)
(cut enqueue-contification! k <>))))))
(define (visit-fun term)
(match term
(($ $fun body)
(visit-cont body))))
(define (visit-cont cont)
(define (compute-contification-candidates conts)
"Compute and return a label -> (variable ...) map describing all
functions with known uses that are only ever used as the operator of a
$call, and are always called with a compatible arity."
(let* ((functions (compute-functions conts))
(vars (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
functions
empty-intmap))
(arities (compute-arities conts functions)))
(define (restrict-arity functions proc nargs)
(match (intmap-ref vars proc (lambda (_) #f))
(#f functions)
(label
(let lp ((arities (intmap-ref arities label)))
(match arities
(() (intmap-remove functions label))
((arity . arities)
(cond
((not (contifiable-arity? arity)) (lp '()))
((arity-matches? arity nargs) functions)
(else (lp arities)))))))))
(define (visit-cont label cont functions)
(define (exclude-var functions var)
(match (intmap-ref vars var (lambda (_) #f))
(#f functions)
(label (intmap-remove functions label))))
(define (exclude-vars functions vars)
(match vars
(() functions)
((var . vars)
(exclude-vars (exclude-var functions var) vars))))
(match cont
(($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
(when alternate (visit-cont alternate)))
(($ $cont)
#t)))
(define (visit-term term term-k)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body term-k))
(($ $continue k src exp)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun
($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k)
(lambda (sym)
(contify-fun term-k sym self tail-k
(extract-arities clause)
(extract-bodies clause))))
(begin
(for-each visit-cont (extract-bodies clause)))
(visit-fun exp)))
(($ $rec names syms funs)
(define (split-components nsf)
;; FIXME: Compute strongly-connected components. Currently
;; we just put non-recursive functions in their own
;; components, and lump everything else in the remaining
;; component.
(define (recursive? k)
(or-map (cut variable-free-in? <> k dfg) syms))
(let lp ((nsf nsf) (rec '()))
(match nsf
(()
(if (null? rec)
'()
(list rec)))
(((and elt (n s ($ $fun ($ $cont kfun))))
. nsf)
(if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
(define (extract-arities+bodies clauses)
(values (map extract-arities clauses)
(map extract-bodies clauses)))
(define (visit-component component)
(match component
(((name sym fun) ...)
(match fun
((($ $fun
($ $cont fun-k
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
clause)))
...)
(call-with-values (lambda () (extract-arities+bodies clause))
(lambda (arities bodies)
;; Technically the procedures are created in
;; term-k but bound for use in k. But, there is
;; a tight link between term-k and k, as they
;; are in the same block. Mark k as the
;; contification scope, because that's where
;; they'll be used. Perhaps we can fix this
;; with the new CPS dialect that doesn't have
;; $letk.
(if (contify-funs k sym self tail-k arities bodies)
(for-each (cut for-each visit-cont <>) bodies)
(for-each visit-fun fun)))))))))
(for-each visit-component
(split-components (map list names syms funs))))
(_ #t)))))
((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
functions)
(($ $values args)
(exclude-vars functions args))
(($ $call proc args)
(let ((functions (exclude-vars functions args)))
;; Note that this contification algorithm is happy to
;; contify the `lp' in this example into a shared tail
;; between clauses:
;;
;; (letrec ((lp (lambda () (lp))))
;; (case-lambda
;; ((a) (lp))
;; ((a b) (lp))))
;;
;; This can cause cross-clause jumps. The rest of the
;; compiler handles this fine though, so we allow it.
(restrict-arity functions proc (length args))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args))
(exclude-vars functions args))
(($ $branch kt ($ $values (arg)))
(exclude-var functions arg))
(($ $primcall name args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
(_ functions)))
(intmap-fold visit-cont conts functions)))
(visit-cont fun)
(values call-substs cont-substs cont-splices)))
(define (compute-call-graph conts labels vars)
"Given the set of contifiable functions LABELS and associated bound
variables VARS, compute and return two values: a map
LABEL->LABEL... indicating the contifiable functions called by a
function, and a map LABEL->LABEL... indicating the return continuations
for a function. The first return value also has an entry
0->LABEL... indicating all contifiable functions called by
non-contifiable functions. We assume that 0 is not in the contifiable
function set."
(let ((bodies
;; label -> fun-label for all labels in bodies of contifiable
;; functions
(intset-fold (lambda (fun-label bodies)
(intset-fold (lambda (label bodies)
(intmap-add bodies label fun-label))
(compute-function-body conts fun-label)
bodies))
labels
empty-intmap)))
(when (intset-ref labels 0)
(error "internal error: label 0 should not be contifiable"))
(intmap-fold
(lambda (label cont calls returns)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $call proc)))
(match (intmap-ref vars proc (lambda (_) #f))
(#f (values calls returns))
(callee
(let ((caller (intmap-ref bodies label (lambda (_) 0))))
(values (intmap-add calls caller callee intset-add)
(intmap-add returns callee k intset-add))))))
(_ (values calls returns))))
conts
(intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
(intset->intmap (lambda (label) empty-intset) labels))))
(define (apply-contification fun call-substs cont-substs cont-splices)
(define (contify-call src proc args)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
(let lp ((clauses clauses))
(match clauses
(() (error "invalid contification"))
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
($continue k src
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
(define (tail-label conts label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail body)
tail)))
(define (compute-return-labels labels tails returns return-substs)
(define (subst k)
(match (intmap-ref return-substs k (lambda (_) #f))
(#f k)
(k (subst k))))
;; Compute all return labels, then subtract tail labels of the
;; functions in question.
(intset-subtract
;; Return labels for all calls to these labels.
(intset-fold (lambda (label out)
(intset-fold (lambda (k out)
(intset-add out (subst k)))
(intmap-ref returns label)
out))
labels
empty-intset)
(intset-fold (lambda (label out)
(intset-add out (intmap-ref tails label)))
labels
empty-intset)))
(define (intmap->intset map)
(define (add-key label cont labels)
(intset-add labels label))
(intmap-fold add-key map empty-intset))
(define (filter-contifiable contified groups)
(intmap-fold (lambda (id labels groups)
(let ((labels (intset-subtract labels contified)))
(if (eq? empty-intset labels)
groups
(intmap-add groups id labels))))
groups
empty-intmap))
(define (trivial-set set)
(let ((first (intset-next set)))
(and first
(not (intset-next set (1+ first)))
first)))
(define (compute-contification conts)
(let*-values
(;; label -> (var ...)
((candidates) (compute-contification-candidates conts))
((labels) (intmap->intset candidates))
;; var -> label
((vars) (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
candidates
empty-intmap))
;; caller-label -> callee-label..., callee-label -> return-label...
((calls returns) (compute-call-graph conts labels vars))
;; callee-label -> tail-label
((tails) (intset-fold
(lambda (label tails)
(intmap-add tails label (tail-label conts label)))
labels
empty-intmap))
;; Strongly connected components, allowing us to contify mutually
;; tail-recursive functions. Since `compute-call-graph' added on
;; a synthetic 0->LABEL... entry for contifiable functions called
;; by non-contifiable functions, we need to remove that entry
;; from the partition. It will be in its own component, as it
;; has no predecessors.
;;
;; id -> label...
((groups) (intmap-remove
(compute-strongly-connected-components calls 0)
0)))
;; todo: thread groups through contification
(define (attempt-contification labels contified return-substs)
(let ((returns (compute-return-labels labels tails returns
return-substs)))
(cond
((trivial-set returns)
=> (lambda (k)
;; Success!
(values (intset-union contified labels)
(intset-fold (lambda (label return-substs)
(let ((tail (intmap-ref tails label)))
(intmap-add return-substs tail k)))
labels return-substs))))
((trivial-set labels)
;; Single-label SCC failed to contify.
(values contified return-substs))
(else
;; Multi-label SCC failed to contify. Try instead to contify
;; each one.
(intset-fold
(lambda (label contified return-substs)
(let ((labels (intset-add empty-intset label)))
(attempt-contification labels contified return-substs)))
labels contified return-substs)))))
(call-with-values
(lambda ()
(fixpoint
(lambda (contified return-substs)
(intmap-fold
(lambda (id group contified return-substs)
(attempt-contification group contified return-substs))
(filter-contifiable contified groups)
contified
return-substs))
empty-intset
empty-intmap))
(lambda (contified return-substs)
(values (intset-fold (lambda (label call-substs)
(intset-fold
(lambda (var call-substs)
(intmap-add call-substs var label))
(intmap-ref candidates label)
call-substs))
contified
empty-intmap)
return-substs)))))
(define (apply-contification conts call-substs return-substs)
(define (call-subst proc)
(intmap-ref call-substs proc (lambda (_) #f)))
(define (return-subst k)
(intmap-ref return-substs k (lambda (_) #f)))
(define (find-body kfun nargs)
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(let lp ((clause clause))
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(if (arity-matches? arity nargs)
body
(lp alt))))))))
(define (continue k src exp)
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(match (return-subst k)
(#f k)
(k (lookup-return-cont k))))
(let ((k* (lookup-return-cont k)))
;; We are contifying this return. It must be a call or a
;; primcall to values, return, or return-values.
(if (eq? k k*)
(build-cps-term ($continue k src ,exp))
(rewrite-cps-term exp
(($ $primcall 'return (val))
($continue k* src ($primcall 'values (val))))
(($ $values vals)
($continue k* src ($primcall 'values vals)))
(_ ($continue k* src ,exp))))))
(define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k)
(#f term)
((cont ...)
(let lp ((term term))
(rewrite-cps-term term
(($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont cont))
,body))
(body
($letk ,(filter-map visit-cont cont)
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
(($ $fun body)
($fun ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names syms body))
;; Remove bindings for functions that have been contified.
,(rewrite-cps-cont (filter (match-lambda
((name sym) (not (assq sym call-substs))))
(map list names syms))
(((names syms) ...)
(label ($kargs names syms ,(visit-term body label))))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
(match term
(($ $letk conts body)
;; Visit the body first, so we rewrite depth-first.
(let lp ((body (visit-term body term-k)))
;; Because we attach contified functions on a particular
;; term-k, and one term-k can correspond to an arbitrarily
;; nested sequence of $letk instances, normalize so that all
;; continuations are bound by one $letk -- guaranteeing that
;; they are in the same scope.
(rewrite-cps-term body
(($ $letk conts* body)
($letk ,(append conts* (filter-map visit-cont conts))
,body))
(body
($letk ,(filter-map visit-cont conts)
,body)))))
(($ $continue k src exp)
(splice-continuations
term-k
(match exp
(($ $fun
($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
;; If the function's tail continuation has been substituted,
;; that means it has been contified.
(continue k src
(if (assq tail-k cont-substs)
(build-cps-exp ($values ()))
(visit-fun exp))))
(($ $rec names syms funs)
(match (filter (match-lambda
((n s f) (not (assq s call-substs))))
(map list names syms funs))
(() (continue k src (build-cps-exp ($values ()))))
(((names syms funs) ...)
(continue k src
(build-cps-exp
($rec names syms (map visit-fun funs)))))))
(($ $call proc args)
(or (contify-call src proc args)
(continue k src exp)))
(_ (continue k src exp)))))))
(visit-cont fun))
(build-term ($continue k src ,exp))
;; We are contifying this return. It must be a call, a
;; $values expression, or a return primcall. k* will be
;; either a $ktail or a $kreceive continuation. CPS has this
;; thing though where $kreceive can't be the target of a
;; $values expression, and "return" can only continue to a
;; tail continuation, so we might have to rewrite to a
;; "values" primcall.
(build-term
($continue k* src
,(match (intmap-ref conts k*)
(($ $kreceive)
(match exp
(($ $call) exp)
;; A primcall that can continue to $ktail can also
;; continue to $kreceive.
(($ $primcall) exp)
(($ $values vals)
(build-exp ($primcall 'values vals)))))
(($ $ktail) exp)))))))
(define (visit-exp k src exp)
(match exp
(($ $call proc args)
;; If proc is contifiable, replace call with jump.
(match (call-subst proc)
(#f (continue k src exp))
(kfun
(let ((body (find-body kfun (length args))))
(build-term ($continue body src ($values args)))))))
(($ $fun kfun)
;; If the function's tail continuation has been
;; substituted, that means it has been contified.
(if (return-subst (tail-label conts kfun))
(continue k src (build-exp ($values ())))
(continue k src exp)))
(($ $rec names vars funs)
(match (filter (match-lambda ((n v f) (not (call-subst v))))
(map list names vars funs))
(() (continue k src (build-exp ($values ()))))
(((names vars funs) ...)
(continue k src (build-exp ($rec names vars funs))))))
(_ (continue k src exp))))
(define (contify fun)
(call-with-values (lambda () (compute-contification fun))
(lambda (call-substs cont-substs cont-splices)
(if (null? call-substs)
fun
;; Iterate to fixed point.
(contify
(apply-contification fun call-substs cont-substs cont-splices))))))
;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been
;; wired into other functions.
(renumber
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
;; Remove bindings for functions that have been contified.
(match (filter (match-lambda ((name var) (not (call-subst var))))
(map list names vars))
(((names vars) ...)
(build-cont
($kargs names vars ,(visit-exp k src exp))))))
(_ cont)))
conts)))
(define (contify conts)
;; FIXME: Renumbering isn't really needed but dead continuations may
;; cause compute-singly-referenced-labels to spuriously mark some
;; conts as irreducible. For now we punt and renumber so that there
;; are only live conts.
(let ((conts (renumber conts)))
(let-values (((call-substs return-substs) (compute-contification conts)))
(apply-contification conts call-substs return-substs))))

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

@ -25,282 +25,242 @@
(define-module (language cps cse)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (rnrs bytevectors)
#:export (eliminate-common-subexpressions))
(define (cont-successors cont)
(match cont
(($ $kargs names syms body)
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler) (list k handler))
(($ $branch kt) (list k kt))
(_ (list k)))))))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(($ $kreceive arity k) (list k))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(($ $kclause arity ($ $cont kbody)) (list kbody))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(($ $kfun src meta self tail clause)
(let lp ((clause clause))
(match clause
(($ $cont kclause ($ $kclause _ _ alt))
(cons kclause (lp alt)))
(#f '()))))
(define (compute-available-expressions conts kfun effects)
"Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
an intset containing ancestor labels whose value is available at LABEL."
(define (propagate avail succ out)
(let* ((in (intmap-ref avail succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() avail)
(values (list succ)
(intmap-add avail succ in* (lambda (old new) new))))))
(($ $kfun src meta self tail #f) '())
(($ $ktail) '())))
(define (compute-available-expressions dfg min-label label-count idoms)
"Compute and return the continuations that may be reached if flow
reaches a continuation N. Returns a vector of intsets, whose first
index corresponds to MIN-LABEL, and so on."
(let* ((effects (compute-effects dfg min-label label-count))
;; Vector of intsets, indicating that at a continuation N, the
;; values from continuations M... are available.
(avail (make-vector label-count #f))
(revisit-label #f))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (get-effects label) (vector-ref effects (label->idx label)))
(define (propagate! pred succ out)
(let* ((succ-idx (label->idx succ))
(in (match (lookup-predecessors succ dfg)
;; Fast path: normal control flow.
((_) out)
;; Slow path: control-flow join.
(_ (cond
((vector-ref avail succ-idx)
=> (lambda (in)
(intset-intersect in out)))
(else out))))))
(when (and (<= succ pred)
(or (not revisit-label) (< succ revisit-label))
(not (eq? in (vector-ref avail succ-idx))))
;; Arrange to revisit if this is not a forward edge and the
;; available set changed.
(set! revisit-label succ))
(vector-set! avail succ-idx in)))
(define (clobber label in)
(let ((fx (get-effects label)))
(cond
((not (causes-effect? fx &write))
;; Fast-path if this expression clobbers nothing.
in)
(else
;; Kill clobbered expressions. There is no need to check on
;; any label before than the last dominating label that
;; clobbered everything.
(let ((first (let lp ((dom label))
(let* ((dom (vector-ref idoms (label->idx dom))))
(and (< min-label dom)
(let ((fx (vector-ref effects (label->idx dom))))
(if (causes-all-effects? fx)
dom
(lp dom))))))))
(let lp ((i first) (in in))
(cond
((intset-next in i)
=> (lambda (i)
(if (effect-clobbers? fx (vector-ref effects (label->idx i)))
(lp (1+ i) (intset-remove in i))
(lp (1+ i) in))))
(else in))))))))
(synthesize-definition-effects! effects dfg min-label label-count)
(vector-set! avail 0 empty-intset)
(let lp ((n 0))
(define (clobber label in)
(let ((fx (intmap-ref effects label)))
(cond
((< n label-count)
(let* ((label (idx->label n))
;; It's possible for "in" to be #f if it has no
;; predecessors, as is the case for the ktail of a
;; function with an iloop.
(in (or (vector-ref avail n) empty-intset))
(out (intset-add (clobber label in) label)))
(lookup-predecessors label dfg)
(let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
(match succs
(() (lp (1+ n)))
((succ . succs)
(propagate! label succ out)
(visit-succs succs))))))
(revisit-label
(let ((n (label->idx revisit-label)))
(set! revisit-label #f)
(lp n)))
((not (causes-effect? fx &write))
;; Fast-path if this expression clobbers nothing.
in)
(else
(values avail effects))))))
;; Kill clobbered expressions. FIXME: there is no need to check
;; on any label before than the last dominating label that
;; clobbered everything. Another way to speed things up would
;; be to compute a clobber set per-effect, which we could
;; subtract from "in".
(let lp ((label 0) (in in))
(cond
((intset-next in label)
=> (lambda (label)
(if (effect-clobbers? fx (intmap-ref effects label))
(lp (1+ label) (intset-remove in label))
(lp (1+ label) in))))
(else in)))))))
(define (compute-truthy-expressions dfg min-label label-count)
(define (visit-cont label avail)
(let* ((in (intmap-ref avail label))
(out (intset-add (clobber label in) label)))
(define (propagate0)
(values '() avail))
(define (propagate1 succ)
(propagate avail succ out))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 avail) (propagate avail succ0 out))
((changed1 avail) (propagate avail succ1 out)))
(values (append changed0 changed1) avail)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate2 k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (compute-truthy-expressions conts kfun)
"Compute a \"truth map\", indicating which expressions can be shown to
be true and/or false at each of LABEL-COUNT expressions in DFG, starting
from MIN-LABEL. Returns a vector of intsets, each intset twice as long
as LABEL-COUNT. 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."
(let ((boolv (make-vector label-count #f))
(revisit-label #f))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (true-idx idx) (ash idx 1))
(define (false-idx idx) (1+ (ash idx 1)))
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! pred succ out)
(let* ((succ-idx (label->idx succ))
(in (match (lookup-predecessors succ dfg)
;; Fast path: normal control flow.
((_) out)
;; Slow path: control-flow join.
(_ (cond
((vector-ref boolv succ-idx)
=> (lambda (in)
(intset-intersect in out)))
(else out))))))
(when (and (<= succ pred)
(or (not revisit-label) (< succ revisit-label))
(not (eq? in (vector-ref boolv succ-idx))))
(set! revisit-label succ))
(vector-set! boolv succ-idx in)))
(define (propagate boolv succ out)
(let* ((in (intmap-ref boolv succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() boolv)
(values (list succ)
(intmap-add boolv succ in* (lambda (old new) new))))))
(vector-set! boolv 0 empty-intset)
(define (visit-cont label boolv)
(let ((in (intmap-ref boolv label)))
(define (propagate0)
(values '() boolv))
(define (propagate1 succ)
(propagate boolv succ in))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 boolv) (propagate boolv succ0 in))
((changed1 boolv) (propagate boolv succ1 in)))
(values (append changed0 changed1) boolv)))
(define (propagate-branch succ0 succ1)
(let*-values (((changed0 boolv)
(propagate boolv succ0
(intset-add in (false-idx label))))
((changed1 boolv)
(propagate boolv succ1
(intset-add in (true-idx label)))))
(values (append changed0 changed1) boolv)))
(let lp ((n 0))
(cond
((< n label-count)
(let* ((label (idx->label n))
;; It's possible for "in" to be #f if it has no
;; predecessors, as is the case for the ktail of a
;; function with an iloop.
(in (or (vector-ref boolv n) empty-intset)))
(define (default-propagate)
(let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
(match succs
(() (lp (1+ n)))
((succ . succs)
(propagate! label succ in)
(visit-succs succs)))))
(match (lookup-cont label dfg)
(($ $kargs names syms body)
(match (find-call body)
(($ $continue k src ($ $branch kt))
(propagate! label k (intset-add in (false-idx n)))
(propagate! label kt (intset-add in (true-idx n)))
(lp (1+ n)))
(_ (default-propagate))))
(_ (default-propagate)))))
(revisit-label
(let ((n (label->idx revisit-label)))
(set! revisit-label #f)
(lp n)))
(else boolv)))))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate-branch k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(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))
(define (intset-map f set)
(persistent-intmap
(intset-fold (lambda (i out) (intmap-add! out i (f i)))
set
empty-intmap)))
;; Returns a map of label-idx -> (var-idx ...) indicating the variables
;; defined by a given labelled expression.
(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
(match (lookup-cont k dfg)
(($ $kargs names vars) vars)
(_ '())))
(define (idx->label idx) (+ idx min-label))
(let ((defs (make-vector label-count '())))
(let lp ((n 0))
(when (< n label-count)
(vector-set!
defs
n
(match (lookup-cont (idx->label n) dfg)
(($ $kargs _ _ body)
(match (find-call body)
(($ $continue k) (cont-defs k))))
(($ $kreceive arity kargs)
(cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kfun src meta self) (list self))
(($ $ktail) '())))
(lp (1+ n))))
defs))
(define (compute-defs conts kfun)
(intset-map (lambda (label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(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 ($ $continue k))
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))))
(compute-function-body conts kfun)))
(define (compute-label-and-var-ranges fun)
(match fun
(($ $cont kfun ($ $kfun src meta self))
((make-local-cont-folder min-label label-count min-var var-count)
(lambda (k cont min-label label-count min-var var-count)
(let ((min-label (min k min-label))
(label-count (1+ label-count)))
(match cont
(($ $kargs names vars body)
(values min-label label-count
(fold min min-var vars) (+ var-count (length vars))))
(($ $kfun src meta self)
(values min-label label-count (min self min-var) (1+ var-count)))
(_
(values min-label label-count min-var var-count)))))
fun kfun 0 self 0))))
(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)))))
;; 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-equivalent-subexpressions conts kfun effects)
(define (visit-fun kfun equiv-labels var-substs)
(let* ((succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs))
(avail (compute-available-expressions conts 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-equivalent-subexpressions fun dfg)
(define (compute min-label label-count min-var var-count idoms avail effects)
(let ((defs (compute-defs dfg min-label label-count))
(var-substs (make-vector var-count #f))
(equiv-labels (make-vector label-count #f))
(equiv-set (make-hash-table)))
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
(define (for-each/2 f l1 l2)
(unless (= (length l1) (length l2))
(error "bad lengths" l1 l2))
(let lp ((l1 l1) (l2 l2))
(when (pair? l1)
(f (car l1) (car l2))
(lp (cdr l1) (cdr l2)))))
(define (subst-var var)
;; It could be that the var is free in this function; if so, its
;; name will be less than min-var.
(let ((idx (var->idx var)))
(if (<= 0 idx)
(vector-ref var-substs idx)
var)))
(define (compute-exp-key exp)
(define (compute-exp-key var-substs exp)
(match exp
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $closure label nfree) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
(cons* 'primcall name (map subst-var args)))
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args))
(cons* 'primcall name (map subst-var args)))
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(define (add-auxiliary-definitions! label exp-key)
(let ((defs (vector-ref defs (label->idx label))))
(define (add-auxiliary-definitions! label var-substs exp-key)
(define (subst var)
(subst-var var-substs var))
(let ((defs (intmap-ref defs label)))
(define (add-def! aux-key var)
(let ((equiv (hash-ref equiv-set aux-key '())))
(hash-set! equiv-set aux-key
@ -309,14 +269,14 @@ could be that both true and false proofs are available."
(('primcall 'box val)
(match defs
((box)
(add-def! `(primcall box-ref ,(subst-var box)) val))))
(add-def! `(primcall box-ref ,(subst box)) val))))
(('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val))
(('primcall 'cons car cdr)
(match defs
((pair)
(add-def! `(primcall car ,(subst-var pair)) car)
(add-def! `(primcall cdr ,(subst-var pair)) cdr))))
(add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr))))
(('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car))
(('primcall 'set-cdr! pair cdr)
@ -324,7 +284,7 @@ could be that both true and false proofs are available."
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs
((vec)
(add-def! `(primcall vector-length ,(subst-var vec)) len))))
(add-def! `(primcall vector-length ,(subst vec)) len))))
(('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val)
@ -332,214 +292,167 @@ could be that both true and false proofs are available."
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size)
(match defs
(() #f) ;; allocate-struct in tail or kreceive position.
((struct)
(add-def! `(primcall struct-vtable ,(subst-var struct))
(add-def! `(primcall struct-vtable ,(subst struct))
vtable))))
(('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
(('primcall 'scm->f64 scm)
(match defs
((f64)
(add-def! `(primcall f64->scm ,f64) scm))))
(('primcall 'f64->scm f64)
(match defs
((scm)
(add-def! `(primcall scm->f64 ,scm) f64))))
(('primcall 'scm->u64 scm)
(match defs
((u64)
(add-def! `(primcall u64->scm ,u64) scm))))
(('primcall 'u64->scm u64)
(match defs
((scm)
(add-def! `(primcall scm->u64 ,scm) u64)
(add-def! `(primcall scm->u64/truncate ,scm) u64))))
(('primcall 'scm->s64 scm)
(match defs
((s64)
(add-def! `(primcall s64->scm ,s64) scm))))
(('primcall 's64->scm s64)
(match defs
((scm)
(add-def! `(primcall scm->s64 ,scm) s64))))
(_ #t))))
;; The initial substs vector is the identity map.
(let lp ((var min-var))
(when (< (var->idx var) var-count)
(vector-set! var-substs (var->idx var) var)
(lp (1+ var))))
(define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let* ((exp-key (compute-exp-key var-substs exp))
(equiv (hash-ref equiv-set exp-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs)
;; 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 var-substs exp-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).
(when (and exp-key
(not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid))))
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(when defs
(hash-set! equiv-set exp-key
(acons label defs equiv)))))
(finish equiv-labels var-substs))
(((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.
(finish (intmap-add equiv-labels label head)
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
var-substs))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in forward order, which will visit
;; dominators first.
(let lp ((label min-label))
(when (< (label->idx label) label-count)
(match (lookup-cont label dfg)
(($ $kargs names vars body)
(match (find-call body)
(($ $continue k src exp)
(let* ((exp-key (compute-exp-key exp))
(equiv (hash-ref equiv-set exp-key '()))
(lidx (label->idx label))
(fx (vector-ref effects lidx))
(avail (vector-ref avail lidx)))
(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).
(when (and exp-key
(not (causes-effect? fx &allocation))
(not (effect-clobbers?
fx
(&read-object &fluid))))
(hash-set! equiv-set exp-key
(acons label (vector-ref defs lidx)
equiv))))
(((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.
(vector-set! equiv-labels lidx head)
;; If we dominate the successor, mark vars
;; for substitution.
(when (= label (vector-ref idoms (label->idx k)))
(for-each/2
(lambda (var subst-var)
(vector-set! var-substs (var->idx var) subst-var))
(vector-ref defs lidx)
vars)))))))
;; 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 exp-key)))))
(_ #f))
(lp (1+ label))))
(values (compute-dom-edges idoms min-label)
equiv-labels min-label var-substs min-var)))
;; 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)))
(call-with-values (lambda () (compute-label-and-var-ranges fun))
(lambda (min-label label-count min-var var-count)
(let ((idoms (compute-idoms dfg min-label label-count)))
(call-with-values
(lambda ()
(compute-available-expressions dfg min-label label-count idoms))
(lambda (avail effects)
(compute min-label label-count min-var var-count
idoms avail effects)))))))
(intset-fold visit-fun
(intmap-keys (compute-reachable-functions conts kfun))
empty-intmap
empty-intmap))
(define (apply-cse fun dfg
doms equiv-labels min-label var-substs min-var boolv)
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
(define (var->idx var) (- var min-var))
(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)
;; It could be that the var is free in this function; if so,
;; its name will be less than min-var.
(let ((idx (var->idx var)))
(if (<= 0 idx)
(vector-ref var-substs idx)
var)))
(intmap-ref var-substs var (lambda (var) var)))
(define (visit-fun-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-fun-cont clause)))))
(($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
(label ($kclause ,arity ,(visit-cont kbody body)
,(and alternate (visit-fun-cont alternate)))))))
(define (visit-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
(define (visit-cont label cont)
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names vars ,(visit-term body label))))
(_ (label ,cont))))
(define (visit-term term label)
(define (visit-exp exp)
;; We shouldn't see $fun here.
(rewrite-cps-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(cse body dfg)))))
(define (visit-exp* k src exp)
(match exp
(($ $fun)
(build-cps-term
($continue k src ,(visit-fun exp))))
(($ $rec names syms funs)
(build-cps-term
($continue k src ($rec names syms (map visit-fun funs)))))
(_
(cond
((vector-ref equiv-labels (label->idx label))
=> (match-lambda
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(build-cont
($kargs names vars
,(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(let* ((eidx (label->idx equiv)))
(match exp
(($ $branch kt exp)
(let* ((bool (vector-ref boolv (label->idx label)))
(t (intset-ref bool (true-idx eidx)))
(f (intset-ref bool (false-idx eidx))))
(if (eqv? t f)
(build-cps-term
($continue k src
($branch kt ,(visit-exp exp))))
(build-cps-term
($continue (if t kt k) src ($values ()))))))
(_
;; FIXME: can we always continue with $values? why
;; or why not?
(rewrite-cps-term (lookup-cont k dfg)
(($ $kargs)
($continue k src ($values vars)))
(_
($continue k src ,(visit-exp exp))))))))))
(else
(build-cps-term
($continue k src ,(visit-exp exp))))))))
(match exp
(($ $branch kt exp)
(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
($continue k src
($branch kt ,(visit-exp exp))))
(build-term
($continue (if t kt k) src ($values ()))))))
(_
;; For better or for worse, we only replace primcalls
;; if they have an associated VM op, which allows
;; them to continue to $kargs and thus we know their
;; defs and can use a $values expression instead of a
;; values primcall.
(build-term
($continue k src ($values vars))))))
(#f
(build-term
($continue k src ,(visit-exp exp))))))))
(_ cont)))
conts))
(define (visit-dom-conts label)
(let ((cont (lookup-cont label dfg)))
(match cont
(($ $ktail) '())
(($ $kargs) (list (visit-cont label cont)))
(else
(cons (visit-cont label cont)
(append-map visit-dom-conts
(vector-ref doms (label->idx label))))))))
(rewrite-cps-term term
(($ $letk conts body)
,(visit-term body label))
(($ $continue k src exp)
,(let ((conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
(if (null? conts)
(visit-exp* k src exp)
(build-cps-term
($letk ,conts ,(visit-exp* k src exp))))))))
(visit-fun-cont fun))
(define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
(lambda (doms equiv-labels min-label var-substs min-var)
(apply-cse fun dfg doms equiv-labels min-label var-substs min-var
(compute-truthy-expressions dfg
min-label (vector-length doms))))))
(define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun))
(lambda (fun nlabels nvars)
(cse fun (compute-dfg fun)))))
(define (eliminate-common-subexpressions conts)
(call-with-values
(lambda ()
(let ((effects (synthesize-definition-effects (compute-effects conts))))
(compute-equivalent-subexpressions conts 0 effects)))
(lambda (equiv-labels var-substs)
(let ((truthy-labels (compute-truthy-expressions conts 0)))
(apply-cse conts equiv-labels var-substs truthy-labels)))))

652
module/language/cps/dce.scm
View file

@ -18,346 +18,346 @@
;;; Commentary:
;;;
;;; Various optimizations can inline calls from one continuation to some
;;; other continuation, usually in response to information about the
;;; return arity of the call. That leaves us with dangling
;;; continuations that aren't reachable any more from the procedure
;;; entry. This pass will remove them.
;;;
;;; This pass also kills dead expressions: code that has no side
;;; effects, and whose value is unused. It does so by marking all live
;;; values, and then discarding other values as dead. This happens
;;; recursively through procedures, so it should be possible to elide
;;; dead procedures as well.
;;; This pass kills dead expressions: code that has no side effects, and
;;; whose value is unused. It does so by marking all live values, and
;;; then discarding other values as dead. This happens recursively
;;; through procedures, so it should be possible to elide dead
;;; procedures as well.
;;;
;;; Code:
(define-module (language cps dce)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps effects-analysis)
#:use-module (language cps renumber)
#:use-module (language cps types)
#:use-module (language cps type-checks)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-dead-code))
(define-record-type $fun-data
(make-fun-data min-label effects live-conts defs)
fun-data?
(min-label fun-data-min-label)
(effects fun-data-effects)
(live-conts fun-data-live-conts)
(defs fun-data-defs))
(define (fold-local-conts proc conts label seed)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let lp ((label label) (seed seed))
(if (<= label tail)
(lp (1+ label) (proc label (intmap-ref conts label) seed))
seed)))))
(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
(match (lookup-cont k dfg)
(($ $kargs names vars) vars)
(_ #f)))
(define (idx->label idx) (+ idx min-label))
(let ((defs (make-vector label-count #f)))
(let lp ((n 0))
(when (< n label-count)
(vector-set!
defs
n
(match (lookup-cont (idx->label n) dfg)
(($ $kargs _ _ body)
(match (find-call body)
(($ $continue k src exp)
(match exp
(($ $branch) #f)
(_ (cont-defs k))))))
(($ $kreceive arity kargs)
(cont-defs kargs))
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kfun src meta self) (list self))
(($ $ktail) #f)))
(lp (1+ n))))
defs))
(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let ((start label))
(let lp ((label tail) (seed0 seed0) (seed1 seed1))
(if (<= start label)
(let ((cont (intmap-ref conts label)))
(call-with-values (lambda () (proc label cont seed0 seed1))
(lambda (seed0 seed1)
(lp (1- label) seed0 seed1))))
(values seed0 seed1)))))))
(define (elide-type-checks! fun dfg effects min-label label-count)
(match fun
(($ $cont kfun ($ $kfun src meta min-var))
(let ((typev (infer-types fun dfg)))
(define (idx->label idx) (+ idx min-label))
(define (var->idx var) (- var min-var))
(define (visit-primcall lidx fx name args)
(when (primcall-types-check? typev (idx->label lidx) name args)
(vector-set! effects lidx
(logand fx (lognot &type-check)))))
(let lp ((lidx 0))
(when (< lidx label-count)
(let ((fx (vector-ref effects lidx)))
(unless (causes-all-effects? fx)
(when (causes-effect? fx &type-check)
(match (lookup-cont (idx->label lidx) dfg)
(($ $kargs _ _ term)
(match (find-call term)
(($ $continue k src ($ $primcall name args))
(visit-primcall lidx fx name args))
(($ $continue k src ($ $branch _ ($primcall name args)))
(visit-primcall lidx fx name args))
(_ #f)))
(_ #f)))))
(lp (1+ lidx))))))))
(define (compute-known-allocations conts effects)
"Compute the variables bound in CONTS that have known allocation
sites."
;; Compute the set of conts that are called with freshly allocated
;; values, and subtract from that set the conts that might be called
;; with values with unknown allocation sites. Then convert that set
;; of conts into a set of bound variables.
(call-with-values
(lambda ()
(intmap-fold (lambda (label cont known unknown)
;; Note that we only need to add labels to the
;; known/unknown sets if the labels can bind
;; values. So there's no need to add tail,
;; clause, branch alternate, or prompt handler
;; labels, as they bind no values.
(match cont
(($ $kargs _ _ ($ $continue k))
(let ((fx (intmap-ref effects label)))
(if (and (not (causes-all-effects? fx))
(causes-effect? fx &allocation))
(values (intset-add! known k) unknown)
(values known (intset-add! unknown k)))))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
(values known unknown))
(($ $kclause arity body alt)
(values known (intset-add! unknown body)))
(($ $ktail)
(values known unknown))))
conts
empty-intset
empty-intset))
(lambda (known unknown)
(persistent-intset
(intset-fold (lambda (label vars)
(match (intmap-ref conts label)
(($ $kargs (_) (var)) (intset-add! vars var))
(_ vars)))
(intset-subtract (persistent-intset known)
(persistent-intset unknown))
empty-intset)))))
(define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table))
(dfg (compute-dfg fun #:global? #t))
(live-vars (make-bitvector (dfg-var-count dfg) #f))
(changed? #f))
(define (mark-live! var)
(unless (value-live? var)
(set! changed? #t)
(bitvector-set! live-vars var #t)))
(define (value-live? var)
(bitvector-ref live-vars var))
(define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun)
(call-with-values (lambda ()
((make-local-cont-folder label-count max-label)
(lambda (k cont label-count max-label)
(values (1+ label-count) (max k max-label)))
fun 0 -1))
(lambda (label-count max-label)
(let* ((min-label (- (1+ max-label) label-count))
(effects (compute-effects dfg min-label label-count))
(live-conts (make-bitvector label-count #f))
(defs (compute-defs dfg min-label label-count))
(fun-data (make-fun-data
min-label effects live-conts defs)))
(elide-type-checks! fun dfg effects min-label label-count)
(hashq-set! fun-data-table fun fun-data)
(set! changed? #t)
fun-data)))))
(define (visit-fun fun)
(match (ensure-fun-data fun)
(($ $fun-data min-label effects live-conts defs)
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (known-allocation? var dfg)
(match (lookup-predecessors (lookup-def var dfg) dfg)
((def-exp-k)
(match (lookup-cont def-exp-k dfg)
(($ $kargs _ _ term)
(match (find-call term)
(($ $continue k src ($ $values (var)))
(known-allocation? var dfg))
(($ $continue k src ($ $primcall))
(let ((kidx (label->idx def-exp-k)))
(and (>= kidx 0)
(causes-effect? (vector-ref effects kidx)
&allocation))))
(_ #f)))
(_ #f)))
(_ #f)))
(define (visit-grey-exp n exp)
(let ((defs (vector-ref defs n))
(fx (vector-ref effects n)))
(or
;; No defs; perhaps continuation is $ktail.
(not defs)
;; Do we have a live def?
(or-map value-live? defs)
;; Does this expression cause all effects? If so, it's
;; definitely live.
(causes-all-effects? fx)
;; Does it cause a type check, but we weren't able to
;; prove that the types check?
(causes-effect? fx &type-check)
;; We might have a setter. If the object being assigned
;; to is live or was not created by us, then this
;; expression is live. Otherwise the value is still dead.
(and (causes-effect? fx &write)
(match exp
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
'box-set!)
(obj . _))
(or (value-live? obj)
(not (known-allocation? obj dfg))))
(_ #t))))))
(let lp ((n (1- (vector-length effects))))
(unless (< n 0)
(let ((cont (lookup-cont (idx->label n) dfg)))
(match cont
(($ $kargs _ _ body)
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
(($ $continue k src exp)
(unless (bitvector-ref live-conts n)
(when (visit-grey-exp n exp)
(set! changed? #t)
(bitvector-set! live-conts n #t)))
(when (bitvector-ref live-conts n)
(match exp
((or ($ $const) ($ $prim))
#f)
(($ $fun body)
(visit-fun body))
(($ $rec names syms funs)
(for-each (lambda (sym fun)
(when (value-live? sym)
(match fun
(($ $fun body)
(visit-fun body)))))
syms funs))
(($ $prompt escape? tag handler)
(mark-live! tag))
(($ $call proc args)
(mark-live! proc)
(for-each mark-live! args))
(($ $callk k proc args)
(mark-live! proc)
(for-each mark-live! args))
(($ $primcall name args)
(for-each mark-live! args))
(($ $branch k ($ $primcall name args))
(for-each mark-live! args))
(($ $branch k ($ $values (arg)))
(mark-live! arg))
(($ $values args)
(match (vector-ref defs n)
(#f (for-each mark-live! args))
(defs (for-each (lambda (use def)
(when (value-live? def)
(mark-live! use)))
args defs))))))))))
(($ $kreceive arity kargs) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms))
(($ $kfun src meta self)
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
(unless (= (dfg-var-count dfg) (var-counter))
(error "internal error" (dfg-var-count dfg) (var-counter)))
(let lp ()
(set! changed? #f)
(visit-fun fun)
(when changed? (lp)))
(values fun-data-table live-vars)))
(define (compute-live-code conts)
(let* ((effects (compute-effects/elide-type-checks conts))
(known-allocations (compute-known-allocations conts effects)))
(define (adjoin-var var set)
(intset-add set var))
(define (adjoin-vars vars set)
(match vars
(() set)
((var . vars) (adjoin-vars vars (adjoin-var var set)))))
(define (var-live? var live-vars)
(intset-ref live-vars var))
(define (any-var-live? vars live-vars)
(match vars
(() #f)
((var . vars)
(or (var-live? var live-vars)
(any-var-live? vars live-vars)))))
(define (cont-defs k)
(match (intmap-ref conts k)
(($ $kargs _ vars) vars)
(_ #f)))
(define (process-eliminations fun fun-data-table live-vars)
(define (value-live? var)
(bitvector-ref live-vars var))
(define (make-adaptor name k defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(syms (map (lambda (_) (fresh-var)) defs))
(live (filter-map (lambda (def sym)
(and (value-live? def)
sym))
defs syms)))
(build-cps-cont
(name ($kargs names syms
($continue k #f ($values live)))))))
(define (visit-fun fun)
(match (hashq-ref fun-data-table fun)
(($ $fun-data min-label effects live-conts defs)
(define (label->idx label) (- label min-label))
(define (visit-cont cont)
(match (visit-cont* cont)
((cont) cont)))
(define (visit-cont* cont)
(match cont
(($ $cont label cont)
(match cont
(($ $kargs names syms body)
(match (filter-map (lambda (name sym)
(and (value-live? sym)
(cons name sym)))
names syms)
(((names . syms) ...)
(list
(build-cps-cont
(label ($kargs names syms
,(visit-term body label))))))))
(($ $kfun src meta self tail clause)
(list
(build-cps-cont
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))))
(($ $kclause arity body alternate)
(list
(build-cps-cont
(label ($kclause ,arity
,(visit-cont body)
,(and alternate
(visit-cont alternate)))))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (vector-ref defs (label->idx label))))
(if (and-map value-live? defs)
(list (build-cps-cont (label ,cont)))
(let-fresh (adapt) ()
(list (make-adaptor adapt kargs defs)
(build-cps-cont
(label ($kreceive req rest adapt))))))))
(_ (list (build-cps-cont (label ,cont))))))))
(define (visit-conts conts)
(append-map visit-cont* conts))
(define (visit-term term term-k)
(match term
(($ $letk conts body)
(let ((body (visit-term body term-k)))
(match (visit-conts conts)
(() body)
(conts (build-cps-term ($letk ,conts ,body))))))
(($ $continue k src ($ $values args))
(match (vector-ref defs (label->idx term-k))
(#f term)
(defs
(let ((args (filter-map (lambda (use def)
(and (value-live? def) use))
args defs)))
(build-cps-term
($continue k src ($values args)))))))
(($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k))
(define (visit-live-exp label k exp live-labels live-vars)
(match exp
((or ($ $const) ($ $prim))
(values live-labels live-vars))
(($ $fun body)
(values (intset-add live-labels body) live-vars))
(($ $closure body)
(values (intset-add live-labels body) live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
(live-labels live-labels) (live-vars live-vars))
(match (vector vars kfuns)
(#(() ()) (values live-labels live-vars))
(#((var . vars) (kfun . kfuns))
(lp vars kfuns
(if (var-live? var live-vars)
(intset-add live-labels kfun)
live-labels)
live-vars)))))
(($ $prompt escape? tag handler)
(values live-labels (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
(adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
(values live-labels (adjoin-vars args live-vars)))
(($ $branch k ($ $values (arg)))
(values live-labels (adjoin-var arg live-vars)))
(($ $values args)
(values live-labels
(match (cont-defs k)
(#f (adjoin-vars args live-vars))
(defs (fold (lambda (use def live-vars)
(if (var-live? def live-vars)
(adjoin-var use live-vars)
live-vars))
live-vars args defs)))))))
(define (visit-exp label k exp live-labels live-vars)
(cond
((intset-ref live-labels label)
;; Expression live already.
(visit-live-exp label k exp live-labels live-vars))
((let ((defs (cont-defs k))
(fx (intmap-ref effects label)))
(or
;; No defs; perhaps continuation is $ktail.
(not defs)
;; We don't remove branches.
(match exp (($ $branch) #t) (_ #f))
;; Do we have a live def?
(any-var-live? defs live-vars)
;; Does this expression cause all effects? If so, it's
;; definitely live.
(causes-all-effects? fx)
;; Does it cause a type check, but we weren't able to prove
;; that the types check?
(causes-effect? fx &type-check)
;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead.
(and (causes-effect? fx &write)
(match exp
(($ $fun body)
(build-cps-term
($continue k src ($fun ,(visit-fun body)))))
(($ $rec names syms funs)
(rewrite-cps-term
(filter-map
(lambda (name sym fun)
(and (value-live? sym)
(match fun
(($ $fun body)
(list name
sym
(build-cps-exp
($fun ,(visit-fun body))))))))
names syms funs)
(()
($continue k src ($values ())))
(((names syms funs) ...)
($continue k src ($rec names syms funs)))))
(_
(match (vector-ref defs (label->idx term-k))
((or #f ((? value-live?) ...))
(build-cps-term
($continue k src ,exp)))
(syms
(let-fresh (adapt) ()
(build-cps-term
($letk (,(make-adaptor adapt k syms))
($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ())))))))
(visit-cont fun))))
(visit-fun fun))
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
'box-set!)
(obj . _))
(or (var-live? obj live-vars)
(not (intset-ref known-allocations obj))))
(_ #t)))))
;; Mark expression as live and visit.
(visit-live-exp label k exp (intset-add live-labels label) live-vars))
(else
;; Still dead.
(values live-labels live-vars))))
(define (eliminate-dead-code fun)
(call-with-values (lambda () (renumber fun))
(lambda (fun nlabels nvars)
(parameterize ((label-counter nlabels)
(var-counter nvars))
(call-with-values (lambda () (compute-live-code fun))
(lambda (fun-data-table live-vars)
(process-eliminations fun fun-data-table live-vars)))))))
(define (visit-fun label live-labels live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
(lambda (label cont live-labels live-vars)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-labels live-vars))
(($ $kreceive arity kargs)
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
(values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
(values live-labels (adjoin-var self live-vars)))
(($ $ktail)
(values live-labels live-vars))))
conts label live-labels live-vars))
(fixpoint (lambda (live-labels live-vars)
(let lp ((label 0)
(live-labels live-labels)
(live-vars live-vars))
(match (intset-next live-labels label)
(#f (values live-labels live-vars))
(label
(call-with-values
(lambda ()
(match (intmap-ref conts label)
(($ $kfun)
(visit-fun label live-labels live-vars))
(_ (values live-labels live-vars))))
(lambda (live-labels live-vars)
(lp (1+ label) live-labels live-vars)))))))
(intset 0)
empty-intset)))
(define-syntax adjoin-conts
(syntax-rules ()
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(adjoin-conts cps clause ...)))
((_ cps (label cont) clause ...)
(adjoin-conts (intmap-add! cps label (build-cont cont))
clause ...))
((_ cps)
cps)))
(define (process-eliminations conts live-labels live-vars)
(define (label-live? label)
(intset-ref live-labels label))
(define (value-live? var)
(intset-ref live-vars var))
(define (make-adaptor k src defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(vars (map (lambda (_) (fresh-var)) defs))
(live (filter-map (lambda (def var)
(and (value-live? def) var))
defs vars)))
(build-cont
($kargs names vars
($continue k src ($values live))))))
(define (visit-term label term cps)
(match term
(($ $continue k src exp)
(if (label-live? label)
(match exp
(($ $fun body)
(values cps
term))
(($ $closure body nfree)
(values cps
term))
(($ $rec names vars funs)
(match (filter-map (lambda (name var fun)
(and (value-live? var)
(list name var fun)))
names vars funs)
(()
(values cps
(build-term ($continue k src ($values ())))))
(((names vars funs) ...)
(values cps
(build-term ($continue k src
($rec names vars funs)))))))
(_
(match (intmap-ref conts k)
(($ $kargs ())
(values cps term))
(($ $kargs names ((? value-live?) ...))
(values cps term))
(($ $kargs names vars)
(match exp
(($ $values args)
(let ((args (filter-map (lambda (use def)
(and (value-live? def) use))
args vars)))
(values cps
(build-term
($continue k src ($values args))))))
(_
(let-fresh (adapt) ()
(values (adjoin-conts cps
(adapt ,(make-adaptor k src vars)))
(build-term
($continue adapt src ,exp)))))))
(_
(values cps term)))))
(values cps
(build-term
($continue k src ($values ()))))))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)
(match (filter-map (lambda (name var)
(and (value-live? var)
(cons name var)))
names vars)
(((names . vars) ...)
(call-with-values (lambda () (visit-term label term cps))
(lambda (cps term)
(adjoin-conts cps
(label ($kargs names vars ,term))))))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (match (intmap-ref conts kargs)
(($ $kargs names vars) vars))))
(if (and-map value-live? defs)
(adjoin-conts cps (label ,cont))
(let-fresh (adapt) ()
(adjoin-conts cps
(adapt ,(make-adaptor kargs #f defs))
(label ($kreceive req rest adapt)))))))
(_
(adjoin-conts cps (label ,cont)))))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold (lambda (label cont cps)
(match cont
(($ $kfun)
(if (label-live? label)
(fold-local-conts visit-cont conts label cps)
cps))
(_ cps)))
conts
empty-intmap))))
(define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses
;; before definitions just by visiting higher-numbered labels before
;; lower-numbered labels. Renumbering is also a precondition for type
;; inference.
(let ((conts (renumber conts)))
(call-with-values (lambda () (compute-live-code conts))
(lambda (live-labels live-vars)
(process-eliminations conts live-labels live-vars)))))
;;; Local Variables:
;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
;;; End:

904
module/language/cps/dfg.scm
View file

@ -1,904 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Many passes rely on a local or global static analysis of a function.
;;; This module implements a simple data-flow graph (DFG) analysis,
;;; tracking the definitions and uses of variables and continuations.
;;; It also builds a table of continuations and scope links, to be able
;;; to easily determine if one continuation is in the scope of another,
;;; and to get to the expression inside a continuation.
;;;
;;; Note that the data-flow graph of continuation labels is a
;;; control-flow graph.
;;;
;;; We currently don't expose details of the DFG type outside this
;;; module, preferring to only expose accessors. That may change in the
;;; future but it seems to work for now.
;;;
;;; Code:
(define-module (language cps dfg)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps intset)
#:export (build-cont-table
lookup-cont
compute-dfg
dfg-cont-table
dfg-min-label
dfg-label-count
dfg-min-var
dfg-var-count
with-fresh-name-state-from-dfg
lookup-def
lookup-uses
lookup-predecessors
lookup-successors
lookup-block-scope
find-call
call-expression
find-expression
find-defining-expression
find-constant-value
continuation-bound-in?
variable-free-in?
constant-needs-allocation?
control-point?
lookup-bound-syms
compute-idoms
compute-dom-edges
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
dfa-var-idx dfa-var-sym dfa-var-count
print-dfa))
;; These definitions are here because currently we don't do cross-module
;; inlining. They can be removed once that restriction is gone.
(define-inlinable (for-each f l)
(unless (list? l)
(scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
(let for-each1 ((l l))
(unless (null? l)
(f (car l))
(for-each1 (cdr l)))))
(define-inlinable (for-each/2 f l1 l2)
(unless (= (length l1) (length l2))
(scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
(list l2) #f))
(let for-each2 ((l1 l1) (l2 l2))
(unless (null? l1)
(f (car l1) (car l2))
(for-each2 (cdr l1) (cdr l2)))))
(define (build-cont-table fun)
(let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
-1 fun)))
(fold-conts (lambda (k cont table)
(vector-set! table k cont)
table)
(make-vector (1+ max-k) #f)
fun)))
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
(make-dfg conts preds defs uses scopes scope-levels
min-label max-label label-count
min-var max-var var-count)
dfg?
;; vector of label -> $kargs, etc
(conts dfg-cont-table)
;; vector of label -> (pred-label ...)
(preds dfg-preds)
;; vector of var -> def-label
(defs dfg-defs)
;; vector of var -> (use-label ...)
(uses dfg-uses)
;; vector of label -> label
(scopes dfg-scopes)
;; vector of label -> int
(scope-levels dfg-scope-levels)
(min-label dfg-min-label)
(max-label dfg-max-label)
(label-count dfg-label-count)
(min-var dfg-min-var)
(max-var dfg-max-var)
(var-count dfg-var-count))
(define-inlinable (vector-push! vec idx val)
(let ((v vec) (i idx))
(vector-set! v i (cons val (vector-ref v i)))))
(define (compute-reachable dfg min-label label-count)
"Compute and return the continuations that may be reached if flow
reaches a continuation N. Returns a vector of intsets, whose first
index corresponds to MIN-LABEL, and so on."
(let (;; Vector of intsets, indicating that continuation N can
;; reach a set M...
(reachable (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
;; Iterate labels backwards, to converge quickly.
(let lp ((label (+ min-label label-count)) (changed? #f))
(cond
((= label min-label)
(if changed?
(lp (+ min-label label-count) #f)
reachable))
(else
(let* ((label (1- label))
(idx (label->idx label))
(old (vector-ref reachable idx))
(new (fold (lambda (succ set)
(cond
((vector-ref reachable (label->idx succ))
=> (lambda (succ-set)
(intset-union set succ-set)))
(else set)))
(or (vector-ref reachable idx)
(intset-add empty-intset label))
(visit-cont-successors list
(lookup-cont label dfg)))))
(cond
((eq? old new)
(lp label changed?))
(else
(vector-set! reachable idx new)
(lp label #t)))))))))
(define (find-prompts dfg min-label label-count)
"Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
pairs."
(let lp ((label min-label) (prompts '()))
(cond
((= label (+ min-label label-count))
(reverse prompts))
(else
(match (lookup-cont label dfg)
(($ $kargs names syms body)
(match (find-expression body)
(($ $prompt escape? tag handler)
(lp (1+ label) (acons label handler prompts)))
(_ (lp (1+ label) prompts))))
(_ (lp (1+ label) prompts)))))))
(define (compute-interval reachable min-label label-count start end)
"Compute and return the set of continuations that may be reached from
START, inclusive, but not reached by END, exclusive. Returns an
intset."
(intset-subtract (vector-ref reachable (- start min-label))
(vector-ref reachable (- end min-label))))
(define (find-prompt-bodies dfg min-label label-count)
"Find all the prompts in DFG from the LABEL-COUNT continuations
starting at MIN-LABEL, and compute the set of continuations that is
reachable from the prompt bodies but not from the corresponding handler.
Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
intset."
(match (find-prompts dfg min-label label-count)
(() '())
(((prompt . handler) ...)
(let ((reachable (compute-reachable dfg min-label label-count)))
(map (lambda (prompt handler)
;; FIXME: It isn't correct to use all continuations
;; reachable from the prompt, because that includes
;; continuations outside the prompt body. This point is
;; moot if the handler's control flow joins with the the
;; body, as is usually but not always the case.
;;
;; One counter-example is when the handler contifies an
;; infinite loop; in that case we compute a too-large
;; prompt body. This error is currently innocuous, but we
;; should fix it at some point.
;;
;; The fix is to end the body at the corresponding "pop"
;; primcall, if any.
(let ((body (compute-interval reachable min-label label-count
prompt handler)))
(list prompt handler body)))
prompt handler)))))
(define* (visit-prompt-control-flow dfg min-label label-count f #: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
body continuation in the prompt."
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(for-each
(match-lambda
((prompt handler body)
(define (out-or-back-edge? label)
;; Most uses of visit-prompt-control-flow don't need every body
;; continuation, and would be happy getting called only for
;; continuations that postdominate the rest of the body. Unless
;; you pass #:complete? #t, we only invoke F on continuations
;; that can leave the body, or on back-edges in loops.
;;
;; You would think that looking for the final "pop" primcall
;; would be sufficient, but that is incorrect; it's possible for
;; a loop in the prompt body to be contified, and that loop need
;; not continue to the pop if it never terminates. The pop could
;; even be removed by DCE, in that case.
(or-map (lambda (succ)
(or (not (intset-ref body succ))
(<= succ label)))
(lookup-successors label dfg)))
(let lp ((label min-label))
(let ((label (intset-next body label)))
(when label
(when (or complete? (out-or-back-edge? label))
(f prompt handler label))
(lp (1+ label)))))))
(find-prompt-bodies dfg min-label label-count)))
(define (analyze-reverse-control-flow fun dfg min-label label-count)
(define (compute-reverse-control-flow-order ktail dfg)
(let ((label-map (make-vector label-count #f))
(next -1))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(let visit ((k ktail))
;; Mark this label as visited.
(vector-set! label-map (label->idx k) #t)
(for-each (lambda (k)
;; Visit predecessors unless they are already visited.
(unless (vector-ref label-map (label->idx k))
(visit k)))
(lookup-predecessors k dfg))
;; Add to reverse post-order chain.
(vector-set! label-map (label->idx k) next)
(set! next k))
(let lp ((n 0) (head next))
(if (< head 0)
;; Add nodes that are not reachable from the tail.
(let lp ((n n) (m label-count))
(unless (= n label-count)
(let find-unvisited ((m (1- m)))
(if (vector-ref label-map m)
(find-unvisited (1- m))
(begin
(vector-set! label-map m n)
(lp (1+ n) m))))))
;; Pop the head off the chain, give it its
;; reverse-post-order numbering, and continue.
(let ((next (vector-ref label-map (label->idx head))))
(vector-set! label-map (label->idx head) n)
(lp (1+ n) next))))
label-map))
(define (convert-successors k-map)
(define (idx->label idx) (+ idx min-label))
(define (renumber label)
(vector-ref k-map (- label min-label)))
(let ((succs (make-vector (vector-length k-map) #f)))
(let lp ((n 0))
(when (< n (vector-length succs))
(vector-set! succs (vector-ref k-map n)
(map renumber
(lookup-successors (idx->label n) dfg)))
(lp (1+ n))))
succs))
(match fun
(($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
(let* ((k-map (compute-reverse-control-flow-order ktail dfg))
(succs (convert-successors k-map)))
;; Any expression in the prompt body could cause an abort to
;; the handler. This code adds links from every block in the
;; prompt body to the handler. This causes all values used
;; by the handler to be seen as live in the prompt body, as
;; indeed they are.
(visit-prompt-control-flow
dfg min-label label-count
(lambda (prompt handler body)
(define (renumber label)
(vector-ref k-map (- label min-label)))
(vector-push! succs (renumber body) (renumber handler))))
(values k-map succs)))))
(define (compute-idoms dfg min-label label-count)
(define preds (dfg-preds dfg))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg)))
(let ((idoms (make-vector label-count #f)))
(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.
(cond
((= d0 d1) d0)
((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
(else (common-idom (vector-ref idoms (label->idx d0)) d1))))
(define (compute-idom preds)
(define (has-idom? pred)
(vector-ref idoms (label->idx pred)))
(match preds
(() min-label)
((pred . preds)
(if (has-idom? pred)
(let lp ((idom pred) (preds preds))
(match preds
(() idom)
((pred . preds)
(lp (if (has-idom? pred)
(common-idom idom pred)
idom)
preds))))
(compute-idom preds)))))
;; 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 iterate ((n 0) (changed? #f))
(cond
((< n label-count)
(let ((idom (vector-ref idoms n))
(idom* (compute-idom (vector-ref preds (idx->dfg-idx n)))))
(cond
((eqv? idom idom*)
(iterate (1+ n) changed?))
(else
(vector-set! idoms n idom*)
(iterate (1+ n) #t)))))
(changed?
(iterate 0 #f))
(else idoms)))))
;; 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 min-label)
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(let ((doms (make-vector (vector-length idoms) '())))
(let lp ((n 0))
(when (< n (vector-length idoms))
(let ((idom (vector-ref idoms n)))
(vector-push! doms (label->idx idom) (idx->label n)))
(lp (1+ n))))
doms))
;; There used to be some loop detection code here, but it bitrotted.
;; We'll need it again eventually but for now it can be found in the git
;; history.
;; Data-flow analysis.
(define-record-type $dfa
(make-dfa min-label min-var var-count in out)
dfa?
;; Minimum label in this function.
(min-label dfa-min-label)
;; Minimum var in this function.
(min-var dfa-min-var)
;; Var count in this function.
(var-count dfa-var-count)
;; Vector of k-idx -> intset
(in dfa-in)
;; Vector of k-idx -> intset
(out dfa-out))
(define (dfa-k-idx dfa k)
(- k (dfa-min-label dfa)))
(define (dfa-k-sym dfa idx)
(+ idx (dfa-min-label dfa)))
(define (dfa-k-count dfa)
(vector-length (dfa-in dfa)))
(define (dfa-var-idx dfa var)
(let ((idx (- var (dfa-min-var dfa))))
(unless (< -1 idx (dfa-var-count dfa))
(error "var out of range" var))
idx))
(define (dfa-var-sym dfa idx)
(unless (< -1 idx (dfa-var-count dfa))
(error "idx out of range" idx))
(+ idx (dfa-min-var dfa)))
(define (dfa-k-in dfa idx)
(vector-ref (dfa-in dfa) idx))
(define (dfa-k-out dfa idx)
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables fun dfg)
;; Compute the maximum fixed point of the data-flow constraint problem.
;;
;; This always completes, as the graph is finite and the in and out sets
;; are complete semi-lattices. If the graph is reducible and the blocks
;; are sorted in reverse post-order, this completes in a maximum of LC +
;; 2 iterations, where LC is the loop connectedness number. See Hecht
;; and Ullman, "Analysis of a simple algorithm for global flow
;; problems", POPL 1973, or the recent summary in "Notes on graph
;; algorithms used in optimizing compilers", Offner 2013.
(define (compute-maximum-fixed-point preds inv outv killv genv)
(define (fold f seed l)
(if (null? l) seed (fold f (f (car l) seed) (cdr l))))
(let lp ((n 0) (changed? #f))
(cond
((< n (vector-length preds))
(let* ((in (vector-ref inv n))
(in* (or
(fold (lambda (pred set)
(cond
((vector-ref outv pred)
=> (lambda (out)
(if set
(intset-union set out)
out)))
(else set)))
in
(vector-ref preds n))
empty-intset)))
(if (eq? in in*)
(lp (1+ n) changed?)
(let ((out* (fold (lambda (gen set)
(intset-add set gen))
(fold (lambda (kill set)
(intset-remove set kill))
in*
(vector-ref killv n))
(vector-ref genv n))))
(vector-set! inv n in*)
(vector-set! outv n out*)
(lp (1+ n) #t)))))
(changed?
(lp 0 #f)))))
(unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
(= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
(error "function needs renumbering"))
(let* ((min-label (dfg-min-label dfg))
(nlabels (dfg-label-count dfg))
(min-var (dfg-min-var dfg))
(nvars (dfg-var-count dfg))
(usev (make-vector nlabels '()))
(defv (make-vector nlabels '()))
(live-in (make-vector nlabels #f))
(live-out (make-vector nlabels #f)))
(call-with-values
(lambda ()
(analyze-reverse-control-flow fun dfg min-label nlabels))
(lambda (k-map succs)
(define (var->idx var) (- var min-var))
(define (idx->var idx) (+ idx min-var))
(define (label->idx label)
(vector-ref k-map (- label min-label)))
;; Initialize defv and usev.
(let ((defs (dfg-defs dfg))
(uses (dfg-uses dfg)))
(let lp ((n 0))
(when (< n (vector-length defs))
(let ((def (vector-ref defs n)))
(unless def
(error "internal error -- var array not packed"))
(for-each (lambda (def)
(vector-push! defv (label->idx def) n))
(lookup-predecessors def dfg))
(for-each (lambda (use)
(vector-push! usev (label->idx use) n))
(vector-ref uses n))
(lp (1+ n))))))
;; Liveness is a reverse data-flow problem, so we give
;; compute-maximum-fixed-point a reversed graph, swapping in for
;; out, usev for defv, and using successors instead of
;; predecessors. Continuation 0 is ktail.
(compute-maximum-fixed-point succs live-out live-in defv usev)
;; Now rewrite the live-in and live-out sets to be indexed by
;; (LABEL - MIN-LABEL).
(let ((live-in* (make-vector nlabels #f))
(live-out* (make-vector nlabels #f)))
(let lp ((idx 0))
(when (< idx nlabels)
(let ((dfa-idx (vector-ref k-map idx)))
(vector-set! live-in* idx (vector-ref live-in dfa-idx))
(vector-set! live-out* idx (vector-ref live-out dfa-idx))
(lp (1+ idx)))))
(make-dfa min-label min-var nvars live-in* live-out*))))))
(define (print-dfa dfa)
(match dfa
(($ $dfa min-label min-var var-count in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (intset-next bv n)))
(when n
(format #t " ~A" (+ n min-var))
(lp (1+ n))))))
(let lp ((n 0))
(when (< n (vector-length in))
(format #t "~A:\n" (+ n min-label))
(format #t " in:")
(print-var-set (vector-ref in n))
(newline)
(format #t " out:")
(print-var-set (vector-ref out n))
(newline)
(lp (1+ n)))))))
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
(define-syntax-rule (do-fold make-cont-folder)
((make-cont-folder min-label max-label label-count
min-var max-var var-count)
(lambda (label cont
min-label max-label label-count
min-var max-var var-count)
(let ((min-label (min* label min-label))
(max-label (max label max-label)))
(match cont
(($ $kargs names vars body)
(values min-label max-label (1+ label-count)
(cond (min-var (fold min min-var vars))
((pair? vars) (fold min (car vars) (cdr vars)))
(else min-var))
(fold max max-var vars)
(+ var-count (length vars))))
(($ $kfun src meta self)
(values min-label max-label (1+ label-count)
(min* self min-var) (max self max-var) (1+ var-count)))
(_ (values min-label max-label (1+ label-count)
min-var max-var var-count)))))
fun
#f -1 0 #f -1 0))
(if global?
(do-fold make-global-cont-folder)
(do-fold make-local-cont-folder)))
(define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?))
(lambda (min-label max-label label-count min-var max-var var-count)
(when (or (zero? label-count) (zero? var-count))
(error "internal error (no vars or labels for fun?)"))
(let* ((nlabels (- (1+ max-label) min-label))
(nvars (- (1+ max-var) min-var))
(conts (make-vector nlabels #f))
(preds (make-vector nlabels '()))
(defs (make-vector nvars #f))
(uses (make-vector nvars '()))
(scopes (make-vector nlabels #f))
(scope-levels (make-vector nlabels #f)))
(define (var->idx var) (- var min-var))
(define (label->idx label) (- label min-label))
(define (add-def! var def-k)
(vector-set! defs (var->idx var) def-k))
(define (add-use! var use-k)
(vector-push! uses (var->idx var) use-k))
(define* (declare-block! label cont parent
#:optional (level
(1+ (vector-ref
scope-levels
(label->idx parent)))))
(vector-set! conts (label->idx label) cont)
(vector-set! scopes (label->idx label) parent)
(vector-set! scope-levels (label->idx label) level))
(define (link-blocks! pred succ)
(vector-push! preds (label->idx succ) pred))
(define (visit-cont cont label)
(match cont
(($ $kargs names syms body)
(for-each (cut add-def! <> label) syms)
(visit-term body label))
(($ $kreceive arity k)
(link-blocks! label k))))
(define (visit-term term label)
(match term
(($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each/2 (lambda (cont k)
(declare-block! k cont label))
cont k)
(for-each/2 visit-cont cont k)
(visit-term body label))
(($ $continue k src exp)
(link-blocks! label k)
(visit-exp exp label))))
(define (visit-exp exp label)
(define (use! sym)
(add-use! sym label))
(match exp
((or ($ $const) ($ $prim) ($ $closure)) #f)
(($ $call proc args)
(use! proc)
(for-each use! args))
(($ $callk k proc args)
(use! proc)
(for-each use! args))
(($ $primcall name args)
(for-each use! args))
(($ $branch kt exp)
(link-blocks! label kt)
(visit-exp exp label))
(($ $values args)
(for-each use! args))
(($ $prompt escape? tag handler)
(use! tag)
(link-blocks! label handler))
(($ $fun body)
(when global?
(visit-fun body)))
(($ $rec names syms funs)
(unless global?
(error "$rec should not be present when building a local DFG"))
(for-each (lambda (fun)
(match fun
(($ $fun body)
(visit-fun body))))
funs))))
(define (visit-clause clause kfun)
(match clause
(#f #t)
(($ $cont kclause
(and clause ($ $kclause arity ($ $cont kbody body)
alternate)))
(declare-block! kclause clause kfun)
(link-blocks! kfun kclause)
(declare-block! kbody body kclause)
(link-blocks! kclause kbody)
(visit-cont body kbody)
(visit-clause alternate kfun))))
(define (visit-fun fun)
(match fun
(($ $cont kfun
(and cont
($ $kfun src meta self ($ $cont ktail tail) clause)))
(declare-block! kfun cont #f 0)
(add-def! self kfun)
(declare-block! ktail tail kfun)
(visit-clause clause kfun))))
(visit-fun fun)
(make-dfg conts preds defs uses scopes scope-levels
min-label max-label label-count
min-var max-var var-count)))))
(define* (dump-dfg dfg #:optional (port (current-output-port)))
(let ((min-label (dfg-min-label dfg))
(min-var (dfg-min-var dfg)))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (var->idx var) (- var min-var))
(define (idx->var idx) (+ idx min-var))
(let lp ((label (dfg-min-label dfg)))
(when (<= label (dfg-max-label dfg))
(let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
(when cont
(unless (equal? (lookup-predecessors label dfg) (list (1- label)))
(newline port))
(format port "k~a:~8t" label)
(match cont
(($ $kreceive arity k)
(format port "$kreceive ~a k~a\n" arity k))
(($ $kfun src meta self tail clause)
(format port "$kfun ~a ~a v~a\n" src meta self))
(($ $ktail)
(format port "$ktail\n"))
(($ $kclause arity ($ $cont kbody) alternate)
(format port "$kclause ~a k~a" arity kbody)
(match alternate
(#f #f)
(($ $cont kalt) (format port " -> k~a" kalt)))
(newline port))
(($ $kargs names vars term)
(unless (null? vars)
(format port "v~a[~a]~:{ v~a[~a]~}: "
(car vars) (car names) (map list (cdr vars) (cdr names))))
(match (find-call term)
(($ $continue kf src ($ $branch kt exp))
(format port "if ")
(match exp
(($ $primcall name args)
(format port "(~a~{ v~a~})" name args))
(($ $values (arg))
(format port "v~a" arg)))
(format port " k~a k~a\n" kt kf))
(($ $continue k src exp)
(match exp
(($ $const val) (format port "const ~@y" val))
(($ $prim name) (format port "prim ~a" name))
(($ $fun ($ $cont kbody)) (format port "fun k~a" kbody))
(($ $rec names syms funs) (format port "rec~{ v~a~}" syms))
(($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
(($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))
(($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args)))
(($ $primcall name args) (format port "~a~{ v~a~}" name args))
(($ $values args) (format port "values~{ v~a~}" args))
(($ $prompt escape? tag handler) (format port "prompt ~a v~a k~a" escape? tag handler)))
(unless (= k (1+ label))
(format port " -> k~a" k))
(newline port))))))
(lp (1+ label)))))))
(define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
(parameterize ((label-counter (1+ (dfg-max-label dfg)))
(var-counter (1+ (dfg-max-var dfg))))
body ...))
(define (lookup-cont label dfg)
(let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
(unless res
(error "Unknown continuation!" label))
res))
(define (lookup-predecessors k dfg)
(vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
(define (lookup-successors k dfg)
(let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
(visit-cont-successors list cont)))
(define (lookup-def var dfg)
(vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
(define (lookup-uses var dfg)
(vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
(define (lookup-block-scope k dfg)
(vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
(define (lookup-scope-level k dfg)
(vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
(define (find-defining-term sym dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k)
(lookup-cont def-exp-k dfg))
(else #f)))
(define (find-call term)
(match term
(($ $kargs names syms body) (find-call body))
(($ $letk conts body) (find-call body))
(($ $continue) term)))
(define (call-expression call)
(match call
(($ $continue k src exp) exp)))
(define (find-expression term)
(call-expression (find-call term)))
(define (find-defining-expression sym dfg)
(match (find-defining-term sym dfg)
(#f #f)
(($ $kreceive) #f)
(($ $kclause) #f)
(term (find-expression term))))
(define (find-constant-value sym dfg)
(match (find-defining-expression sym dfg)
(($ $const val)
(values #t val))
(else
(values #f #f))))
(define (constant-needs-allocation? var val dfg)
(define (immediate-u8? val)
(and (integer? val) (exact? val) (<= 0 val 255)))
(define (find-exp term)
(match term
(($ $kargs names vars body) (find-exp body))
(($ $letk conts body) (find-exp body))
(else term)))
(or-map
(lambda (use)
(match (find-expression (lookup-cont use dfg))
(($ $call) #f)
(($ $callk) #f)
(($ $values) #f)
(($ $primcall 'free-ref (closure slot))
(eq? var closure))
(($ $primcall 'free-set! (closure slot value))
(or (eq? var closure) (eq? var value)))
(($ $primcall 'cache-current-module! (mod . _))
(eq? var mod))
(($ $primcall 'cached-toplevel-box _)
#f)
(($ $primcall 'cached-module-box _)
#f)
(($ $primcall 'resolve (name bound?))
(eq? var name))
(($ $primcall 'make-vector/immediate (len init))
(eq? var init))
(($ $primcall 'vector-ref/immediate (v i))
(eq? var v))
(($ $primcall 'vector-set!/immediate (v i x))
(or (eq? var v) (eq? var x)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(eq? var vtable))
(($ $primcall 'struct-ref/immediate (s n))
(eq? var s))
(($ $primcall 'struct-set!/immediate (s n x))
(or (eq? var s) (eq? var x)))
(($ $primcall 'builtin-ref (idx))
#f)
(_ #t)))
(vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
(define (continuation-scope-contains? scope-k k dfg)
(let ((scope-level (lookup-scope-level scope-k dfg)))
(let lp ((k k))
(or (eq? scope-k k)
(and (< scope-level (lookup-scope-level k dfg))
(lp (lookup-block-scope k dfg)))))))
(define (continuation-bound-in? k use-k dfg)
(continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
(define (variable-free-in? var k dfg)
(or-map (lambda (use)
(continuation-scope-contains? k use dfg))
(lookup-uses var dfg)))
;; A continuation is a control point if it has multiple predecessors, or
;; if its single predecessor does not have a single successor.
(define (control-point? k dfg)
(match (lookup-predecessors k dfg)
((pred)
(let ((cont (vector-ref (dfg-cont-table dfg)
(- pred (dfg-min-label dfg)))))
(visit-cont-successors (case-lambda
(() #t)
((succ0) #f)
((succ1 succ2) #t))
cont)))
(_ #t)))
(define (lookup-bound-syms k dfg)
(match (lookup-cont k dfg)
(($ $kargs names syms body)
syms)))

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

@ -41,11 +41,12 @@
(define-module (language cps effects-analysis)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (ice-9 match)
#:export (expression-effects
compute-effects
synthesize-definition-effects!
synthesize-definition-effects
&allocation
&type-check
@ -61,7 +62,9 @@
&module
&struct
&string
&thread
&bytevector
&closure
&object
&field
@ -168,6 +171,9 @@
;; Indicates that an expression depends on the current module.
&module
;; Indicates that an expression depends on the current thread.
&thread
;; Indicates that an expression depends on the value of a struct
;; field. The effect field indicates the specific field, or zero for
;; an unknown field.
@ -179,7 +185,10 @@
;; Indicates that an expression depends on the contents of a
;; bytevector. We cannot be more precise, as bytevectors may alias
;; other bytevectors.
&bytevector)
&bytevector
;; Indicates a dependency on a free variable of a closure.
&closure)
(define-inlinable (&field kind field)
(ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
@ -227,32 +236,26 @@ is or might be a read or a write to the same location as A."
(not (zero? (logand b (logior &read &write))))
(locations-same?)))
(define (lookup-constant-index sym dfg)
(call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? val)
(and has-const? (integer? val) (exact? val) (<= 0 val) val))))
(define-inlinable (indexed-field kind n dfg)
(cond
((lookup-constant-index n dfg)
=> (lambda (idx)
(&field kind idx)))
(else (&object kind))))
(define-inlinable (indexed-field kind var constants)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(if (and (exact-integer? val) (<= 0 val))
(&field kind val)
(&object kind))))
(define *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* dfg
(define-syntax-rule (define-primitive-effects* constants
((name . args) effects ...)
...)
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda*
((dfg . args) (logior effects ...))
((constants . args) (logior effects ...))
(_ &all-effects)))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
(define-primitive-effects* dfg ((name . args) effects ...) ...))
(define-primitive-effects* constants ((name . args) effects ...) ...))
;; Miscellaneous.
(define-primitive-effects
@ -284,7 +287,15 @@ is or might be a read or a write to the same location as A."
((fluid-ref f) (&read-object &fluid) &type-check)
((fluid-set! f v) (&write-object &fluid) &type-check)
((push-fluid f v) (&write-object &fluid) &type-check)
((pop-fluid) (&write-object &fluid) &type-check))
((pop-fluid) (&write-object &fluid))
((push-dynamic-state state) (&write-object &fluid) &type-check)
((pop-dynamic-state) (&write-object &fluid)))
;; Threads. Calls cause &all-effects, which reflects the fact that any
;; call can capture a partial continuation and reinstate it on another
;; thread.
(define-primitive-effects
((current-thread) (&read-object &thread)))
;; Prompts.
(define-primitive-effects
@ -310,38 +321,38 @@ is or might be a read or a write to the same location as A."
((box-set! v x) (&write-object &box) &type-check))
;; Vectors.
(define (vector-field n dfg)
(indexed-field &vector n dfg))
(define (read-vector-field n dfg)
(logior &read (vector-field n dfg)))
(define (write-vector-field n dfg)
(logior &write (vector-field n dfg)))
(define-primitive-effects* dfg
(define (vector-field n constants)
(indexed-field &vector n constants))
(define (read-vector-field n constants)
(logior &read (vector-field n constants)))
(define (write-vector-field n constants)
(logior &write (vector-field n constants)))
(define-primitive-effects* constants
((vector . _) (&allocate &vector))
((make-vector n init) (&allocate &vector) &type-check)
((make-vector n init) (&allocate &vector))
((make-vector/immediate n init) (&allocate &vector))
((vector-ref v n) (read-vector-field n dfg) &type-check)
((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
((vector-set! v n x) (write-vector-field n dfg) &type-check)
((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
((vector-ref v n) (read-vector-field n constants) &type-check)
((vector-ref/immediate v n) (read-vector-field n constants) &type-check)
((vector-set! v n x) (write-vector-field n constants) &type-check)
((vector-set!/immediate v n x) (write-vector-field n constants) &type-check)
((vector-length v) &type-check))
;; Structs.
(define (struct-field n dfg)
(indexed-field &struct n dfg))
(define (read-struct-field n dfg)
(logior &read (struct-field n dfg)))
(define (write-struct-field n dfg)
(logior &write (struct-field n dfg)))
(define-primitive-effects* dfg
(define (struct-field n constants)
(indexed-field &struct n constants))
(define (read-struct-field n constants)
(logior &read (struct-field n constants)))
(define (write-struct-field n constants)
(logior &write (struct-field n constants)))
(define-primitive-effects* constants
((allocate-struct vt n) (&allocate &struct) &type-check)
((allocate-struct/immediate v n) (&allocate &struct) &type-check)
((make-struct vt ntail . _) (&allocate &struct) &type-check)
((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
((struct-ref s n) (read-struct-field n dfg) &type-check)
((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
((struct-set! s n x) (write-struct-field n dfg) &type-check)
((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
((struct-ref s n) (read-struct-field n constants) &type-check)
((struct-ref/immediate s n) (read-struct-field n constants) &type-check)
((struct-set! s n x) (write-struct-field n constants) &type-check)
((struct-set!/immediate s n x) (write-struct-field n constants) &type-check)
((struct-vtable s) &type-check))
;; Strings.
@ -352,9 +363,22 @@ is or might be a read or a write to the same location as A."
((string->number _) (&read-object &string) &type-check)
((string-length s) &type-check))
;; Unboxed floats and integers.
(define-primitive-effects
((scm->f64 _) &type-check)
((load-f64 _))
((f64->scm _))
((scm->u64 _) &type-check)
((scm->u64/truncate _) &type-check)
((load-u64 _))
((u64->scm _))
((scm->s64 _) &type-check)
((load-s64 _))
((s64->scm _)))
;; Bytevectors.
(define-primitive-effects
((bytevector-length _) &type-check)
((bv-length _) &type-check)
((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
@ -378,6 +402,17 @@ is or might be a read or a write to the same location as A."
((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
;; Closures.
(define (closure-field n constants)
(indexed-field &closure n constants))
(define (read-closure-field n constants)
(logior &read (closure-field n constants)))
(define (write-closure-field n constants)
(logior &write (closure-field n constants)))
(define-primitive-effects* constants
((free-ref closure idx) (read-closure-field idx constants))
((free-set! closure idx val) (write-closure-field idx constants)))
;; Modules.
(define-primitive-effects
((current-module) (&read-object &module))
@ -385,7 +420,7 @@ is or might be a read or a write to the same location as A."
((resolve name bound?) (&read-object &module) &type-check)
((cached-toplevel-box scope name bound?) &type-check)
((cached-module-box mod name public? bound?) &type-check)
((define! name val) (&read-object &module) (&write-object &box)))
((define! name) (&read-object &module)))
;; Numbers.
(define-primitive-effects
@ -394,13 +429,38 @@ is or might be a read or a write to the same location as A."
((> . _) &type-check)
((<= . _) &type-check)
((>= . _) &type-check)
((u64-= . _))
((u64-< . _))
((u64-> . _))
((u64-<= . _))
((u64->= . _))
((u64-<-scm . _) &type-check)
((u64-<=-scm . _) &type-check)
((u64-=-scm . _) &type-check)
((u64->=-scm . _) &type-check)
((u64->-scm . _) &type-check)
((f64-= . _))
((f64-< . _))
((f64-> . _))
((f64-<= . _))
((f64->= . _))
((zero? . _) &type-check)
((add . _) &type-check)
((add/immediate . _) &type-check)
((mul . _) &type-check)
((sub . _) &type-check)
((sub/immediate . _) &type-check)
((div . _) &type-check)
((sub1 . _) &type-check)
((add1 . _) &type-check)
((fadd . _))
((fsub . _))
((fmul . _))
((fdiv . _))
((uadd . _))
((usub . _))
((umul . _))
((uadd/immediate . _))
((usub/immediate . _))
((umul/immediate . _))
((quo . _) &type-check)
((rem . _) &type-check)
((mod . _) &type-check)
@ -418,7 +478,16 @@ is or might be a read or a write to the same location as A."
((logand . _) &type-check)
((logior . _) &type-check)
((logxor . _) &type-check)
((logsub . _) &type-check)
((lognot . _) &type-check)
((ulogand . _))
((ulogior . _))
((ulogxor . _))
((ulogsub . _))
((ursh . _))
((ulsh . _))
((ursh/immediate . _))
((ulsh/immediate . _))
((logtest a b) &type-check)
((logbit? a b) &type-check)
((sqrt _) &type-check)
@ -426,56 +495,55 @@ is or might be a read or a write to the same location as A."
;; Characters.
(define-primitive-effects
((char<? . _) &type-check)
((char<=? . _) &type-check)
((char>=? . _) &type-check)
((char>? . _) &type-check)
((integer->char _) &type-check)
((char->integer _) &type-check))
(define (primitive-effects dfg name args)
;; Atomics are a memory and a compiler barrier; they cause all effects
;; so no need to have a case for them here. (Though, see
;; https://jfbastien.github.io/no-sane-compiler/.)
(define (primitive-effects constants name args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc dfg args)
(apply proc constants args)
&all-effects)))
(define (expression-effects exp dfg)
(define (expression-effects exp constants)
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
((or ($ $fun) ($ $rec))
(($ $closure _ 0)
&no-effects)
((or ($ $fun) ($ $rec) ($ $closure))
(&allocate &unknown-memory-kinds))
(($ $prompt)
(&write-object &prompt))
;; Although the "main" path just writes &prompt, we don't know what
;; nonlocal predecessors of the handler do, so we conservatively
;; assume &all-effects.
&all-effects)
((or ($ $call) ($ $callk))
&all-effects)
(($ $branch k exp)
(expression-effects exp dfg))
(expression-effects exp constants))
(($ $primcall name args)
(primitive-effects dfg name args))))
(primitive-effects constants name args))))
(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
(label-count (dfg-label-count dfg)))
(let ((effects (make-vector label-count &no-effects)))
(define (idx->label idx) (+ idx min-label))
(let lp ((n 0))
(when (< n label-count)
(vector-set!
effects
n
(match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
(expression-effects (find-expression body) dfg))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
(lp (1+ n))))
effects))
(define (compute-effects conts)
(let ((constants (compute-constant-values conts)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp constants))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
conts)))
;; There is a way to abuse effects analysis in CSE to also do scalar
;; replacement, effectively adding `car' and `cdr' expressions to `cons'
@ -487,13 +555,9 @@ is or might be a read or a write to the same location as A."
;; that allocations aren't eliminated anyway, and the new effects will
;; just cause the allocations not to commute with e.g. set-car! which
;; is what we want anyway.
(define* (synthesize-definition-effects! effects dfg min-label #:optional
(label-count (vector-length effects)))
(define (label->idx label) (- label min-label))
(let lp ((label min-label))
(when (< label (+ min-label label-count))
(let* ((lidx (label->idx label))
(fx (vector-ref effects lidx)))
(unless (zero? (logand (logior &write &allocation) fx))
(vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
(lp (1+ label))))))
(define (synthesize-definition-effects effects)
(intmap-map (lambda (label fx)
(if (logtest (logior &write &allocation) fx)
(logior fx &read)
fx))
effects))

125
module/language/cps/elide-values.scm
View file

@ -30,80 +30,59 @@
(define-module (language cps elide-values)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:export (elide-values))
(define (elide-values* fun conts)
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (vector-ref conts k)
(($ $ktail)
($continue k src ($values vals)))
(($ $kreceive ($ $arity req () rest () #f) kargs)
,(cond
((and (not rest) (= (length vals) (length req)))
(build-cps-term
($continue kargs src ($values vals))))
((and rest (>= (length vals) (length req)))
(let-fresh (krest) (rest)
(let ((vals* (append (list-head vals (length req))
(list rest))))
(build-cps-term
($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-fresh (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
(let ((vals (list-head vals (length args))))
(build-cps-term
($continue k src ($values vals))))))))
(($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue)
,term)))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun cont)
($fun ,(visit-cont cont)))))
(define (inline-values cps k src args)
(match (intmap-ref cps k)
(($ $ktail)
(with-cps cps
(build-term
($continue k src ($values args)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(cond
((and (not rest) (= (length args) (length req)))
(with-cps cps
(build-term
($continue kargs src ($values args)))))
((and rest (>= (length args) (length req)))
(let ()
(define (build-rest cps k tail)
(match tail
(()
(with-cps cps
(build-term ($continue k src ($const '())))))
((v . tail)
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue k src ($primcall 'cons (v rest)))))
($ (build-rest krest tail))))))
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue kargs src
($values ,(append (list-head args (length req))
(list rest))))))
($ (build-rest krest (list-tail args (length req)))))))
(else (with-cps cps #f))))))
(visit-cont fun))
(define (elide-values fun)
(with-fresh-name-state fun
(let ((conts (build-cont-table fun)))
(elide-values* fun conts))))
(define (elide-values conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall 'values args)))
(call-with-values (lambda () (inline-values out k src args))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts))))

69
module/language/cps/handle-interrupts.scm Normal file
View file

@ -0,0 +1,69 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2016 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:
;;;
;;; A pass to add "handle-interrupts" primcalls before calls, loop
;;; back-edges, and returns.
;;;
;;; Code:
(define-module (language cps handle-interrupts)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps renumber)
#:export (add-handle-interrupts))
(define (compute-safepoints cps)
(define (visit-cont label cont safepoints)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(let ((safepoints (if (<= k label)
(intset-add! safepoints k)
safepoints)))
(if (match exp
(($ $call) #t)
(($ $callk) #t)
(($ $values)
(match (intmap-ref cps k)
(($ $ktail) #t)
(_ #f)))
(_ #f))
(intset-add! safepoints label)
safepoints)))
(_ safepoints)))
(persistent-intset (intmap-fold visit-cont cps empty-intset)))
(define (add-handle-interrupts cps)
(define (add-safepoint label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(with-cps cps
(letk k* ($kargs () () ($continue k src ,exp)))
(setk label
($kargs names vars
($continue k* src
($primcall 'handle-interrupts ()))))))))
(let* ((cps (renumber cps))
(safepoints (compute-safepoints cps)))
(with-fresh-name-state cps
(persistent-intmap (intset-fold add-safepoint safepoints cps)))))

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

@ -33,8 +33,8 @@
(define-module (language cps intmap)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-18)
#:use-module (ice-9 match)
#:use-module ((ice-9 threads) #:select (current-thread))
#:export (empty-intmap
intmap?
transient-intmap?

101
module/language/cps/intset.scm
View file

@ -29,6 +29,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:use-module ((ice-9 threads) #:select (current-thread))
#:export (empty-intset
intset?
transient-intset?
@ -40,7 +41,9 @@
intset-remove
intset-ref
intset-next
intset-prev
intset-fold
intset-fold-right
intset-union
intset-intersect
intset-subtract
@ -100,7 +103,6 @@
(root transient-intset-root set-transient-intset-root!)
(edit transient-intset-edit set-transient-intset-edit!))
(define (new-leaf) 0)
(define-inlinable (clone-leaf-and-set leaf i val)
(if val
(if leaf
@ -116,9 +118,13 @@
(let ((vec (make-vector *branch-size-with-edit* #f)))
(when edit (vector-set! vec *edit-index* edit))
vec))
(define (clone-branch-and-set branch i elt)
(define-inlinable (clone-branch-and-set branch i elt)
(let ((new (new-branch #f)))
(when branch (vector-move-left! branch 0 *branch-size* new 0))
(when branch
(let lp ((n 0))
(when (< n *branch-size*)
(vector-set! new n (vector-ref branch n))
(lp (1+ n)))))
(vector-set! new i elt)
new))
(define-inlinable (assert-readable! root-edit)
@ -135,7 +141,7 @@
(and (not (vector-ref branch i))
(lp (1+ i))))))
(define (round-down min shift)
(define-inlinable (round-down min shift)
(logand min (lognot (1- (ash 1 shift)))))
(define empty-intset (make-intset 0 *leaf-bits* #f))
@ -391,31 +397,62 @@
(assert-readable! edit)
(next min shift root))))
(define-syntax-rule (make-intset-folder seed ...)
(define* (intset-prev bs #:optional i)
(define (visit-leaf node i)
(let lp ((idx (logand i *leaf-mask*)))
(if (logbit? idx node)
(logior (logand i (lognot *leaf-mask*)) idx)
(let ((idx (1- idx)))
(and (<= 0 idx) (lp idx))))))
(define (visit-branch node shift i)
(let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
(and (<= 0 idx)
(or (let ((node (vector-ref node idx)))
(and node (visit-node node shift i)))
(lp (1- (round-down i shift)) (1- idx))))))
(define (visit-node node shift i)
(if (= shift *leaf-bits*)
(visit-leaf node i)
(visit-branch node (- shift *branch-bits*) i)))
(define (prev min shift root)
(let ((i (if (and i (<= i (+ min (ash 1 shift))))
(- i min)
(1- (ash 1 shift)))))
(and root (<= 0 i)
(let ((i (visit-node root shift i)))
(and i (+ min i))))))
(match bs
(($ <intset> min shift root)
(prev min shift root))
(($ <transient-intset> min shift root edit)
(assert-readable! edit)
(prev min shift root))))
(define-syntax-rule (make-intset-folder forward? seed ...)
(lambda (f set seed ...)
(define (visit-branch node shift min seed ...)
(cond
((= shift *leaf-bits*)
(let lp ((i 0) (seed seed) ...)
(if (< i *leaf-size*)
(let lp ((i (if forward? 0 (1- *leaf-size*))) (seed seed) ...)
(if (if forward? (< i *leaf-size*) (<= 0 i))
(if (logbit? i node)
(call-with-values (lambda () (f (+ i min) seed ...))
(lambda (seed ...)
(lp (1+ i) seed ...)))
(lp (1+ i) seed ...))
(lp (if forward? (1+ i) (1- i)) seed ...)))
(lp (if forward? (1+ i) (1- i)) seed ...))
(values seed ...))))
(else
(let ((shift (- shift *branch-bits*)))
(let lp ((i 0) (seed seed) ...)
(if (< i *branch-size*)
(let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
(if (if forward? (< i *branch-size*) (<= 0 i))
(let ((elt (vector-ref node i)))
(if elt
(call-with-values
(lambda ()
(visit-branch elt shift (+ min (ash i shift)) seed ...))
(lambda (seed ...)
(lp (1+ i) seed ...)))
(lp (1+ i) seed ...)))
(lp (if forward? (1+ i) (1- i)) seed ...)))
(lp (if forward? (1+ i) (1- i)) seed ...)))
(values seed ...)))))))
(match set
(($ <intset> min shift root)
@ -428,11 +465,20 @@
(define intset-fold
(case-lambda
((f set seed)
((make-intset-folder seed) f set seed))
((make-intset-folder #t seed) f set seed))
((f set s0 s1)
((make-intset-folder s0 s1) f set s0 s1))
((make-intset-folder #t s0 s1) f set s0 s1))
((f set s0 s1 s2)
((make-intset-folder s0 s1 s2) f set s0 s1 s2))))
((make-intset-folder #t s0 s1 s2) f set s0 s1 s2))))
(define intset-fold-right
(case-lambda
((f set seed)
((make-intset-folder #f seed) f set seed))
((f set s0 s1)
((make-intset-folder #f s0 s1) f set s0 s1))
((f set s0 s1 s2)
((make-intset-folder #f s0 s1 s2) f set s0 s1 s2))))
(define (intset-size shift root)
(cond
@ -508,6 +554,8 @@
(match (cons a b)
((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
(cond
((not b-root) a)
((not a-root) b)
((not (= b-shift a-shift))
;; Hoist the set with the lowest shift to meet the one with the
;; higher shift.
@ -529,10 +577,10 @@
(else (make-intset a-min a-shift root)))))))))
(define (intset-intersect a b)
(define tmp (new-leaf))
;; Intersect leaves.
(define (intersect-leaves a b)
(logand a b))
(let ((leaf (logand a b)))
(if (eqv? leaf 0) #f leaf)))
;; Intersect A and B from index I; the result will be fresh.
(define (intersect-branches/fresh shift a b i fresh)
(let lp ((i 0))
@ -644,10 +692,10 @@
(else (make-intset/prune a-min a-shift root)))))))))
(define (intset-subtract a b)
(define tmp (new-leaf))
;; Intersect leaves.
(define (subtract-leaves a b)
(logand a (lognot b)))
(let ((out (logand a (lognot b))))
(if (zero? out) #f out)))
;; Subtract B from A starting at index I; the result will be fresh.
(define (subtract-branches/fresh shift a b i fresh)
(let lp ((i 0))
@ -719,7 +767,9 @@
(new (lp a-min a-shift old)))
(if (eq? old new)
a-root
(clone-branch-and-set a-root a-idx new)))))))))))
(let ((root (clone-branch-and-set a-root a-idx new)))
(and (or new (not (branch-empty? root)))
root))))))))))))
(define (bitvector->intset bv)
(define (finish-tail out min tail)
@ -764,13 +814,8 @@
(match ranges
(()
(format port "#<~a>" tag))
(((0 . _) . _)
(format port "#<~a ~a>" tag (range-string ranges)))
(((min . end) . ranges)
(let ((ranges (map (match-lambda
((start . end) (cons (- start min) (- end min))))
(acons min end ranges))))
(format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
(_
(format port "#<~a ~a>" tag (range-string ranges))))))
(define (print-intset intset port)
(print-helper port "intset" intset))

308
module/language/cps/licm.scm Normal file
View file

@ -0,0 +1,308 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Loop invariant code motion (LICM) hoists terms that don't affect a
;;; loop out of the loop, so that the loop goes faster.
;;;
;;; Code:
(define-module (language cps licm)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps effects-analysis)
#:use-module (language cps type-checks)
#:export (hoist-loop-invariant-code))
(define (find-exits scc succs)
(intset-fold (lambda (label exits)
(if (eq? empty-intset
(intset-subtract (intmap-ref succs label) scc))
exits
(intset-add exits label)))
scc
empty-intset))
(define (find-entry scc preds)
(trivial-intset (find-exits scc preds)))
(define (list->intset l)
(persistent-intset
(fold1 (lambda (i set) (intset-add! set i)) l empty-intset)))
(define (loop-invariant? label exp loop-vars loop-effects always-reached?)
(let ((fx (intmap-ref loop-effects label)))
(and
(not (causes-effect? fx &allocation))
(or always-reached?
(not (causes-effect? fx &type-check)))
(or (not (causes-effect? fx &write))
(intmap-fold (lambda (label fx* invariant?)
(and invariant?
(not (effect-clobbers? fx fx*))))
loop-effects #t))
(or (not (causes-effect? fx &read))
(intmap-fold (lambda (label fx* invariant?)
(and invariant?
(not (effect-clobbers? fx* fx))))
loop-effects #t))
(match exp
((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ?
(($ $branch) #f)
(($ $primcall 'values) #f)
(($ $primcall name args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))
(($ $values args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args))))))
(define (hoist-one cps label cont preds
loop-vars loop-effects pre-header-label always-reached?)
(define (filter-loop-vars names vars)
(match (vector names vars)
(#((name . names) (var . vars))
(if (intset-ref loop-vars var)
(let-values (((names vars) (filter-loop-vars names vars)))
(values (cons name names) (cons var vars)))
(filter-loop-vars names vars)))
(_ (values '() '()))))
(define (adjoin-loop-vars loop-vars vars)
(fold1 (lambda (var loop-vars) (intset-add loop-vars var))
vars loop-vars))
(define (hoist-exp src exp def-names def-vars pre-header-label)
(let* ((hoisted-label pre-header-label)
(pre-header-label (fresh-label))
(hoisted-cont
(rewrite-cont (intmap-ref cps hoisted-label)
(($ $kargs names vars)
($kargs names vars
($continue pre-header-label src ,exp)))))
(pre-header-cont
(rewrite-cont (intmap-ref cps hoisted-label)
(($ $kargs _ _ term)
($kargs def-names def-vars ,term)))))
(values (intmap-add! (intmap-replace! cps hoisted-label hoisted-cont)
pre-header-label pre-header-cont)
pre-header-label)))
(define (hoist-call src exp req rest def-names def-vars pre-header-label)
(let* ((hoisted-label pre-header-label)
(receive-label (fresh-label))
(pre-header-label (fresh-label))
(hoisted-cont
(rewrite-cont (intmap-ref cps hoisted-label)
(($ $kargs names vars)
($kargs names vars
($continue receive-label src ,exp)))))
(receive-cont
(build-cont
($kreceive req rest pre-header-label)))
(pre-header-cont
(rewrite-cont (intmap-ref cps hoisted-label)
(($ $kargs _ _ term)
($kargs def-names def-vars ,term)))))
(values (intmap-add!
(intmap-add! (intmap-replace! cps hoisted-label hoisted-cont)
receive-label receive-cont)
pre-header-label pre-header-cont)
pre-header-label)))
(match cont
(($ $kargs names vars ($ $continue k src exp))
;; If k is a loop exit, it will be nullary.
(let-values (((names vars) (filter-loop-vars names vars)))
(match (intmap-ref cps k)
(($ $kargs def-names def-vars)
(cond
((not (loop-invariant? label exp loop-vars loop-effects
always-reached?))
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
(loop-vars (match exp
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive arity kargs)
(match (intmap-ref cps kargs)
(($ $kargs names vars)
(adjoin-loop-vars loop-vars vars))))))
(_ loop-vars)))
(cont (build-cont
($kargs names vars
($continue k src ,exp))))
(always-reached?
(and always-reached?
(match exp
(($ $branch) #f)
(_ (not (causes-effect? (intmap-ref loop-effects label)
&type-check)))))))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?)))
((trivial-intset (intmap-ref preds k))
(let-values
(((cps pre-header-label)
(hoist-exp src exp def-names def-vars pre-header-label))
((cont) (build-cont
($kargs names vars
($continue k src ($values ()))))))
(values cps cont loop-vars (intmap-remove loop-effects label)
pre-header-label always-reached?)))
(else
(let*-values
(((def-names def-vars)
(match (intmap-ref cps k)
(($ $kargs names vars) (values names vars))))
((loop-vars) (adjoin-loop-vars loop-vars def-vars))
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
((cps pre-header-label)
(hoist-exp src exp def-names fresh-vars pre-header-label))
((cont) (build-cont
($kargs names vars
($continue k src ($values fresh-vars))))))
(values cps cont loop-vars (intmap-remove loop-effects label)
pre-header-label always-reached?)))))
(($ $kreceive ($ $arity req () rest) kargs)
(match (intmap-ref cps kargs)
(($ $kargs def-names def-vars)
(cond
((not (loop-invariant? label exp loop-vars loop-effects
always-reached?))
(let* ((loop-vars (adjoin-loop-vars loop-vars def-vars))
(cont (build-cont
($kargs names vars
($continue k src ,exp)))))
(values cps cont loop-vars loop-effects pre-header-label #f)))
((trivial-intset (intmap-ref preds k))
(let ((loop-effects
(intmap-remove (intmap-remove loop-effects label) k)))
(let-values
(((cps pre-header-label)
(hoist-call src exp req rest def-names def-vars
pre-header-label))
((cont) (build-cont
($kargs names vars
($continue kargs src ($values ()))))))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?))))
(else
(let*-values
(((loop-vars) (adjoin-loop-vars loop-vars def-vars))
((fresh-vars) (map (lambda (_) (fresh-var)) def-vars))
((cps pre-header-label)
(hoist-call src exp req rest def-names fresh-vars
pre-header-label))
((cont) (build-cont
($kargs names vars
($continue kargs src
($values fresh-vars))))))
(values cps cont loop-vars loop-effects
pre-header-label always-reached?))))))))))
(($ $kreceive ($ $arity req () rest) kargs)
(values cps cont loop-vars loop-effects pre-header-label
always-reached?))))
(define (hoist-in-loop cps entry body-labels succs preds effects)
(let* ((interior-succs (intmap-map (lambda (label succs)
(intset-intersect succs body-labels))
succs))
(sorted-labels (compute-reverse-post-order interior-succs entry))
(header-label (fresh-label))
(header-cont (intmap-ref cps entry))
(loop-vars (match header-cont
(($ $kargs names vars) (list->intset vars))))
(loop-effects (persistent-intmap
(intset-fold
(lambda (label loop-effects)
(let ((label*
(if (eqv? label entry) header-label label))
(fx (intmap-ref effects label)))
(intmap-add! loop-effects label* fx)))
body-labels empty-intmap)))
(pre-header-label entry)
(pre-header-cont (match header-cont
(($ $kargs names vars term)
(let ((vars* (map (lambda (_) (fresh-var)) vars)))
(build-cont
($kargs names vars*
($continue header-label #f
($values vars*))))))))
(cps (intmap-add! cps header-label header-cont))
(cps (intmap-replace! cps pre-header-label pre-header-cont))
(to-visit (match sorted-labels
((head . tail)
(unless (eqv? head entry) (error "what?"))
(cons header-label tail)))))
(define (rename-back-edges cont)
(define (rename label) (if (eqv? label entry) header-label label))
(rewrite-cont cont
(($ $kargs names vars ($ $continue kf src ($ $branch kt exp)))
($kargs names vars
($continue (rename kf) src ($branch (rename kt) ,exp))))
(($ $kargs names vars ($ $continue k src exp))
($kargs names vars
($continue (rename k) src ,exp)))
(($ $kreceive ($ $arity req () rest) k)
($kreceive req rest (rename k)))))
(let lp ((cps cps) (to-visit to-visit)
(loop-vars loop-vars) (loop-effects loop-effects)
(pre-header-label pre-header-label) (always-reached? #t))
(match to-visit
(() cps)
((label . to-visit)
(call-with-values
(lambda ()
(hoist-one cps label (intmap-ref cps label) preds
loop-vars loop-effects
pre-header-label always-reached?))
(lambda (cps cont
loop-vars loop-effects pre-header-label always-reached?)
(lp (intmap-replace! cps label (rename-back-edges cont)) to-visit
loop-vars loop-effects pre-header-label always-reached?))))))))
(define (hoist-in-function kfun body cps)
(let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs))
(loops (intmap-fold
(lambda (id scc loops)
(cond
((trivial-intset scc) loops)
((find-entry scc preds)
=> (lambda (entry) (intmap-add! loops entry scc)))
(else loops)))
(compute-strongly-connected-components succs kfun)
empty-intmap)))
(if (eq? empty-intset loops)
cps
(let ((effects (compute-effects/elide-type-checks
(intset-fold (lambda (label body-conts)
(intmap-add! body-conts label
(intmap-ref cps label)))
body empty-intmap))))
(persistent-intmap
(intmap-fold (lambda (entry scc cps)
(hoist-in-loop cps entry scc succs preds effects))
loops cps))))))
(define (hoist-loop-invariant-code cps)
(with-fresh-name-state cps
(intmap-fold hoist-in-function
(compute-reachable-functions cps)
cps)))

133
module/language/cps/optimize.scm Normal file
View file

@ -0,0 +1,133 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Optimizations on CPS.
;;;
;;; Code:
(define-module (language cps optimize)
#:use-module (ice-9 match)
#:use-module (language cps constructors)
#:use-module (language cps contification)
#:use-module (language cps cse)
#:use-module (language cps dce)
#:use-module (language cps elide-values)
#:use-module (language cps licm)
#:use-module (language cps peel-loops)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps prune-bailouts)
#:use-module (language cps rotate-loops)
#:use-module (language cps self-references)
#:use-module (language cps simplify)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps specialize-numbers)
#:use-module (language cps type-fold)
#:use-module (language cps verify)
#:export (optimize-higher-order-cps
optimize-first-order-cps
cps-default-optimization-options))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define *debug?* #f)
(define (maybe-verify program)
(if *debug?*
(verify program)
program))
(define-syntax-rule (define-optimizer optimize (pass kw default) ...)
(define* (optimize program #:optional (opts '()))
;; This series of assignments to `program' used to be a series of
;; let* bindings of `program', as you would imagine. In compiled
;; code this is fine because the compiler is able to allocate all
;; let*-bound variable to the same slot, which also means that the
;; garbage collector doesn't have to retain so many copies of the
;; term being optimized. However during bootstrap, the interpreter
;; doesn't do this optimization, leading to excessive data retention
;; as the terms are rewritten. To marginally improve bootstrap
;; memory usage, here we use set! instead. The compiler should
;; produce the same code in any case, though currently it does not
;; because it doesn't do escape analysis on the box created for the
;; set!.
(maybe-verify program)
(set! program
(if (kw-arg-ref opts kw default)
(maybe-verify (pass program))
program))
...
(maybe-verify program)))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
(define-optimizer optimize-higher-order-cps
;; FIXME: split-rec call temporarily moved to compile-bytecode and run
;; unconditionally, because closure conversion requires it. Move the
;; pass back here when that's fixed.
;;
;; (split-rec #:split-rec? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
(prune-top-level-scopes #:prune-top-level-scopes? #t)
(simplify #:simplify? #t)
(contify #:contify? #t)
(inline-constructors #:inline-constructors? #t)
(elide-values #:elide-values? #t)
(prune-bailouts #:prune-bailouts? #t)
(peel-loops #:peel-loops? #t)
(eliminate-common-subexpressions #:cse? #t)
(type-fold #:type-fold? #t)
(resolve-self-references #:resolve-self-references? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
(simplify #:simplify? #t))
(define-optimizer optimize-first-order-cps
(specialize-numbers #:specialize-numbers? #t)
(hoist-loop-invariant-code #:licm? #t)
(eliminate-common-subexpressions #:cse? #t)
(eliminate-dead-code #:eliminate-dead-code? #t)
;; Running simplify here enables rotate-loops to do a better job.
(simplify #:simplify? #t)
(rotate-loops #:rotate-loops? #t)
(simplify #:simplify? #t)
(specialize-primcalls #:specialize-primcalls? #t))
(define (cps-default-optimization-options)
(list ;; #:split-rec? #t
#:simplify? #t
#:eliminate-dead-code? #t
#:prune-top-level-scopes? #t
#:contify? #t
#:inline-constructors? #t
#:specialize-primcalls? #t
#:elide-values? #t
#:prune-bailouts? #t
#:peel-loops? #t
#:cse? #t
#:type-fold? #t
#:resolve-self-references? #t
#:specialize-numbers? #t
#:licm? #t
#:rotate-loops? #t))

287
module/language/cps/peel-loops.scm Normal file
View file

@ -0,0 +1,287 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Loop peeling "peels off" one iteration of a loop. When followed by
;;; common subexpression elimination, it has the effect of moving terms
;;; to the first peeled iteration, leaving the loop body with fewer
;;; terms.
;;;
;;; Loop peeling is complementary to loop-invariant code motion (LICM).
;;; LICM will hoist invariant terms that have no side effects, like
;;; $const, even if they are in branches that are not always taken.
;;; However LICM won't hoist expressions that might have side effects if
;;; it can't prove that they are reachable on every iteration. Peeling
;;; on the other hand arranges for the body to be dominated by one loop
;;; iteration, so any effect that is reachable on one full iteration can
;;; be hoisted and eliminated, which is a big boon when we consider
;;; &type-check effects. For example:
;;;
;;; x = cached-toplevel-box map
;;; y = box-ref x
;;; z = cached-toplevel-box foo
;;; w = box-ref z
;;; ...
;;;
;;; In this example, LICM could hoist X, possibly Y as well if it can
;;; prove that the body doesn't write to variables, but it won't hoist
;;; Z. In contrast, peeling + CSE will allow Z to be hoisted.
;;;
;;; Peeling does cause code growth. If this becomes a problem we will
;;; need to apply heuristics to limit its applicability.
;;;
;;; Implementation-wise, things are complicated by values flowing out of
;;; the loop. We actually perform this transformation only on loops
;;; that have a single exit continuation, so that we define values
;;; flowing out in one place. We rename the loop variables in two
;;; places internally: one for the peeled iteration, and another for
;;; the body. The loop variables' original names are then bound in a
;;; join continuation for use by successor code.
;;;
;;; Code:
(define-module (language cps peel-loops)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (peel-loops))
(define (intset-map f set)
(persistent-intmap
(intset-fold (lambda (i out) (intmap-add! out i (f i))) set empty-intmap)))
(define (loop-successors scc succs)
(intset-subtract (intset-fold (lambda (label exits)
(intset-union exits (intmap-ref succs label)))
scc empty-intset)
scc))
(define (find-exits scc succs)
(intset-fold (lambda (label exits)
(if (eq? empty-intset
(intset-subtract (intmap-ref succs label) scc))
exits
(intset-add exits label)))
scc
empty-intset))
(define (find-entry scc preds)
(trivial-intset (find-exits scc preds)))
(define (list->intset vars)
(persistent-intset
(fold1 (lambda (var set) (intset-add! set var)) vars empty-intset)))
(define (compute-live-variables cps entry body succs)
(let* ((succs (intset-map (lambda (label)
(intset-intersect (intmap-ref succs label) body))
body))
(init (intset-map (lambda (label) #f) body))
(kill (intset-map (lambda (label) #f) body))
(gen (intset-map (lambda (label)
(match (intmap-ref cps label)
(($ $kargs names vars) (list->intset vars))
(_ empty-intset)))
body))
(in (intmap-replace init entry (intmap-ref gen entry)))
(out init))
(define (subtract in kill) (or in empty-intset))
(define (add in gen) (if in (intset-union in gen) gen))
(define (meet in out) (if in (intset-intersect in out) out))
(call-with-values (lambda ()
(solve-flow-equations succs in out kill gen
subtract add meet
(intset entry)))
(lambda (in out)
out))))
(define (compute-out-vars cps entry body succs exit)
(let ((live (compute-live-variables cps entry body succs)))
(intset-fold-right
cons
(intmap-fold (lambda (label succs live-out)
(if (intset-ref succs exit)
(if live-out
(intset-intersect live-out (intmap-ref live label))
(intmap-ref live label))
live-out))
succs #f)
'())))
(define (rename-cont cont fresh-labels fresh-vars)
(define (rename-label label)
(intmap-ref fresh-labels label (lambda (label) label)))
(define (rename-var var)
(intmap-ref fresh-vars var (lambda (var) var)))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $closure) ($ $rec ())) ,exp)
(($ $values args)
($values ,(map rename-var args)))
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
(($ $branch kt ($ $values (arg)))
($branch (rename-label kt) ($values ((rename-var arg)))))
(($ $branch kt ($ $primcall name args))
($branch (rename-label kt) ($primcall name ,(map rename-var args))))
(($ $primcall name args)
($primcall name ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(rewrite-cont cont
(($ $kargs names vars ($ $continue k src exp))
($kargs names (map rename-var vars)
($continue (rename-label k) src ,(rename-exp exp))))
(($ $kreceive ($ $arity req () rest) kargs)
($kreceive req rest (rename-label kargs)))))
(define (compute-var-names conts)
(persistent-intmap
(intmap-fold (lambda (label cont out)
(match cont
(($ $kargs names vars)
(fold (lambda (name var out)
(intmap-add! out var name))
out names vars))
(_ out)))
conts empty-intmap)))
(define (peel-loop cps entry body-labels succs preds)
(let* ((body-conts (intset-map (lambda (label) (intmap-ref cps label))
body-labels))
(var-names (compute-var-names body-conts))
;; All loop exits branch to this label.
(exit (trivial-intset (loop-successors body-labels succs)))
;; The variables that flow out of the loop, as a list.
(out-vars (compute-out-vars cps entry body-labels succs exit))
(out-names (map (lambda (var) (intmap-ref var-names var)) out-vars))
(join-label (fresh-label))
(join-cont (build-cont
($kargs out-names out-vars
($continue exit #f ($values ())))))
(trampoline-cont
;; A $values predecessor for the join, passing the out-vars
;; using their original names. These will get renamed in
;; both the peeled iteration and the body.
(build-cont
($kargs () ()
($continue join-label #f ($values out-vars)))))
(fresh-body-labels
;; Fresh labels for the body.
(intset-map (lambda (old) (fresh-label)) body-labels))
(fresh-body-vars
;; Fresh vars for the body.
(intmap-map (lambda (var name) (fresh-var)) var-names))
(fresh-body-entry
;; The name of the entry, but in the body.
(intmap-ref fresh-body-labels entry))
(fresh-peeled-vars
;; Fresh names for variables that flow out of the peeled iteration.
(fold1 (lambda (var out) (intmap-add out var (fresh-var)))
out-vars empty-intmap))
(peeled-trampoline-label
;; Label for trampoline to pass values out of the peeled
;; iteration.
(fresh-label))
(peeled-trampoline-cont
;; Trampoline for the peeled iteration, ready to adjoin to
;; CPS.
(rename-cont trampoline-cont empty-intmap fresh-peeled-vars))
(peeled-labels
;; Exit goes to trampoline, back edges to body.
(intmap-add (intmap-add empty-intmap exit peeled-trampoline-label)
entry fresh-body-entry))
(peeled-iteration
;; The peeled iteration.
(intmap-map (lambda (label cont)
(rename-cont cont peeled-labels fresh-peeled-vars))
body-conts))
(body-trampoline-label
;; Label for trampoline to pass values out of the body.
(fresh-label))
(body-trampoline-cont
;; Trampoline for the body, ready to adjoin to CPS.
(rename-cont trampoline-cont empty-intmap fresh-body-vars))
(fresh-body
;; The body, renamed.
(let ((label-map (intmap-add fresh-body-labels
exit body-trampoline-label)))
(persistent-intmap
(intmap-fold
(lambda (label new-label out)
(intmap-add! out new-label
(rename-cont (intmap-ref body-conts label)
label-map fresh-body-vars)))
fresh-body-labels empty-intmap)))))
(let* ((cps (intmap-add! cps join-label join-cont))
(cps (intmap-add! cps peeled-trampoline-label
peeled-trampoline-cont))
(cps (intmap-add! cps body-trampoline-label
body-trampoline-cont))
(cps (intmap-fold (lambda (label cont cps)
(intmap-replace! cps label cont))
peeled-iteration cps))
(cps (intmap-fold (lambda (label cont cps)
(intmap-add! cps label cont))
fresh-body cps)))
cps)))
(define (peel-loops-in-function kfun body cps)
(let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs)))
;; We can peel if there is one successor to the loop, and if the
;; loop has no nested functions. (Peeling a nested function would
;; cause exponential code growth.)
(define (can-peel? body)
(and (trivial-intset (loop-successors body succs))
(intset-fold (lambda (label peel?)
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun) #f)
(($ $rec (_ . _)) #f)
(_ peel?)))
(_ peel?)))
body #t)))
(intmap-fold
(lambda (id scc cps)
(cond
((trivial-intset scc) cps)
((find-entry scc preds)
=> (lambda (entry)
(if (can-peel? scc)
(peel-loop cps entry scc succs preds)
cps)))
(else cps)))
(compute-strongly-connected-components succs kfun)
cps)))
(define (peel-loops cps)
(persistent-intmap
(with-fresh-name-state cps
(intmap-fold peel-loops-in-function
(compute-reachable-functions cps)
cps))))

26
module/language/cps/primitives.scm
View file

@ -34,13 +34,15 @@
))
(define *instruction-aliases*
'((+ . add) (1+ . add1)
(- . sub) (1- . sub1)
(* . mul) (/ . div)
'((+ . add)
(- . sub)
(* . mul)
(/ . div)
(quotient . quo) (remainder . rem)
(modulo . mod)
(variable-ref . box-ref)
(variable-set! . box-set!)
(bytevector-length . bv-length)
(bytevector-u8-ref . bv-u8-ref)
(bytevector-u16-native-ref . bv-u16-ref)
(bytevector-u32-native-ref . bv-u32-ref)
@ -82,13 +84,27 @@
(char? . (1 . 1))
(eq? . (1 . 2))
(eqv? . (1 . 2))
(equal? . (1 . 2))
(= . (1 . 2))
(< . (1 . 2))
(> . (1 . 2))
(<= . (1 . 2))
(>= . (1 . 2))
(logtest . (1 . 2))))
(u64-= . (1 . 2))
(u64-< . (1 . 2))
(u64-> . (1 . 2))
(u64-<= . (1 . 2))
(u64->= . (1 . 2))
(u64-<-scm . (1 . 2))
(u64-<=-scm . (1 . 2))
(u64-=-scm . (1 . 2))
(u64->=-scm . (1 . 2))
(u64->-scm . (1 . 2))
(logtest . (1 . 2))
(f64-= . (1 . 2))
(f64-< . (1 . 2))
(f64-> . (1 . 2))
(f64-<= . (1 . 2))
(f64->= . (1 . 2))))
(define (compute-prim-instructions)
(let ((table (make-hash-table)))

125
module/language/cps/prune-bailouts.scm
View file

@ -25,77 +25,62 @@
(define-module (language cps prune-bailouts)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-bailouts))
(define (module-box src module name public? bound? val-proc)
(let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
(define (compute-tails conts)
"For each LABEL->CONT entry in the intmap CONTS, compute a
LABEL->TAIL-LABEL indicating the tail continuation of each expression's
containing function. In some cases TAIL-LABEL might not be available,
for example if there is a stale $kfun pointing at a body, or for
unreferenced terms. In that case TAIL-LABEL is either absent or #f."
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kfun src meta self tail clause)
(intset-fold (lambda (label out)
(intmap-add out label tail (lambda (old new) #f)))
(compute-function-body conts label)
out))
(_ out)))
conts
empty-intmap))
(define (primitive-ref name k src)
(module-box #f '(guile) name #f #t
(lambda (box)
(build-cps-term
($continue k src ($primcall 'box-ref (box)))))))
(define (prune-bailout out tails k src exp)
(match (intmap-ref out k)
(($ $ktail)
(with-cps out #f))
(_
(match (intmap-ref tails k (lambda (_) #f))
(#f
(with-cps out #f))
(ktail
(with-cps out
(letv prim rest)
(letk kresult ($kargs ('rest) (rest)
($continue ktail src ($values ()))))
(letk kreceive ($kreceive '() 'rest kresult))
(build-term ($continue kreceive src ,exp))))))))
(define (prune-bailouts* fun)
(define (visit-cont cont ktail)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body ktail))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause ktail)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body ktail)
,(and alternate (visit-cont alternate ktail)))))
(_ ,cont)))
(define (visit-term term ktail)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
,(visit-term body ktail)))
(($ $continue k src exp)
,(visit-exp k src exp ktail))))
(define (visit-exp k src exp ktail)
(rewrite-cps-term exp
(($ $fun) ($continue k src ,(visit-fun exp)))
(($ $rec names vars funs)
($continue k src ($rec names vars (map visit-fun funs))))
(($ $primcall (and name (or 'error 'scm-error 'throw)) args)
,(if (eq? k ktail)
(build-cps-term ($continue k src ,exp))
(let-fresh (kprim kresult kreceive) (prim rest)
(build-cps-term
($letk ((kresult ($kargs ('rest) (rest)
($continue ktail src ($values ()))))
(kreceive ($kreceive '() 'rest kresult))
(kprim ($kargs ('prim) (prim)
($continue kreceive src
($call prim args)))))
,(primitive-ref name kprim src))))))
(_ ($continue k src ,exp))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(prune-bailouts* body)))))
(rewrite-cps-cont fun
(($ $cont kfun
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(kfun ($kfun src meta self (ktail ($ktail))
,(and clause (visit-cont clause ktail)))))))
(define (prune-bailouts fun)
(with-fresh-name-state fun
(prune-bailouts* fun)))
(define (prune-bailouts conts)
(let ((tails (compute-tails conts)))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars
($ $continue k src
(and exp ($ $primcall (or 'error 'scm-error 'throw)))))
(call-with-values (lambda () (prune-bailout out tails k src exp))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts)))))

115
module/language/cps/prune-top-level-scopes.scm
View file

@ -25,90 +25,39 @@
(define-module (language cps prune-top-level-scopes)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-top-level-scopes))
(define (compute-referenced-scopes fun)
(let ((scope-name->used? (make-hash-table))
(scope-var->used? (make-hash-table))
(k->scope-var (make-hash-table)))
;; Visit uses before defs. That way we know when visiting defs
;; whether the scope is used or not.
(define (visit-cont cont)
(define (compute-used-scopes conts constants)
(persistent-intset
(intmap-fold
(lambda (label cont used-scopes)
(match cont
(($ $cont k ($ $kargs (name) (var) body))
(visit-term body)
(when (hashq-get-handle scope-var->used? var)
(hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body))
(visit-term body))
(($ $cont k ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont k ($ $kclause arity body alternate))
(visit-cont body)
(when alternate (visit-cont alternate)))
(($ $cont k ($ $kreceive))
#t)))
(define (visit-term term)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body))
(($ $continue k src exp)
(match exp
(($ $fun) (visit-fun exp))
(($ $rec names syms funs)
(for-each visit-fun funs))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(hashq-set! scope-var->used? scope #t))
(($ $primcall 'cache-current-module! (module scope))
(hashq-set! scope-var->used? scope #f))
(($ $const val)
;; If there is an entry in the table for "k", it means "val"
;; is a scope symbol, bound for use by cached-toplevel-box
;; or cache-current-module!, or possibly both (though this
;; is not currently the case).
(and=> (hashq-ref k->scope-var k)
(lambda (scope-var)
(when (hashq-ref scope-var->used? scope-var)
;; We have a use via cached-toplevel-box. Mark
;; this scope as used.
(hashq-set! scope-name->used? val #t))
(when (and (hashq-ref scope-name->used? val)
(not (hashq-ref scope-var->used? scope-var)))
;; There is a use, and this sym is used by
;; cache-current-module!.
(hashq-set! scope-var->used? scope-var #t)))))
(_ #t)))))
(define (visit-fun fun)
(match fun
(($ $fun body)
(visit-cont body))))
(($ $kargs _ _
($ $continue k src
($ $primcall 'cached-toplevel-box (scope name bound?))))
(intset-add! used-scopes (intmap-ref constants scope)))
(_
used-scopes)))
conts
empty-intset)))
(visit-cont fun)
scope-var->used?))
(define (prune-top-level-scopes fun)
(let ((scope-var->used? (compute-referenced-scopes fun)))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont sym ($ $kreceive))
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src
(and ($ $primcall 'cache-current-module! (module scope))
(? (lambda _
(not (hashq-ref scope-var->used? scope))))))
($continue k src ($primcall 'values ())))
(($ $continue)
,term)))
(visit-cont fun)))
(define (prune-top-level-scopes conts)
(let* ((constants (compute-constant-values conts))
(used-scopes (compute-used-scopes conts constants)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars
($ $continue k src
($ $primcall 'cache-current-module!
(module (? (lambda (scope)
(let ((val (intmap-ref constants scope)))
(not (intset-ref used-scopes val)))))))))
(build-cont ($kargs names vars
($continue k src ($values ())))))
(_
cont)))
conts)))

217
module/language/cps/reify-primitives.scm
View file

@ -27,22 +27,25 @@
(define-module (language cps reify-primitives)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps primitives)
#:use-module (language cps intmap)
#:use-module (language bytecode)
#:export (reify-primitives))
(define (module-box src module name public? bound? val-proc)
(let-fresh (kbox) (module-var name-var public?-var bound?-var box)
(build-cps-term
($letconst (('module module-var module)
('name name-var name)
('public? public?-var public?)
('bound? bound?-var bound?))
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox src
($primcall 'cached-module-box
(module-var name-var public?-var bound?-var))))))))
(define (module-box cps src module name public? bound? val-proc)
(with-cps cps
(letv box)
(let$ body (val-proc box))
(letk kbox ($kargs ('box) (box) ,body))
($ (with-cps-constants ((module module)
(name name)
(public? public?)
(bound? bound?))
(build-term ($continue kbox src
($primcall 'cached-module-box
(module name public? bound?))))))))
(define (primitive-module name)
(case name
@ -72,107 +75,105 @@
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
'(rnrs bytevectors))
((atomic-box?
make-atomic-box atomic-box-ref atomic-box-set!
atomic-box-swap! atomic-box-compare-and-swap!)
'(ice-9 atomic))
((current-thread) '(ice-9 threads))
((class-of) '(oop goops))
((u8vector-ref
u8vector-set! s8vector-ref s8vector-set!
u16vector-ref u16vector-set! s16vector-ref s16vector-set!
u32vector-ref u32vector-set! s32vector-ref s32vector-set!
u64vector-ref u64vector-set! s64vector-ref s64vector-set!
f32vector-ref f32vector-set! f64vector-ref f64vector-set!)
'(srfi srfi-4))
(else '(guile))))
(define (primitive-ref name k src)
(module-box #f (primitive-module name) name #f #t
(lambda (box)
(build-cps-term
($continue k src ($primcall 'box-ref (box)))))))
(define (primitive-ref cps name k src)
(module-box cps src (primitive-module name) name #f #t
(lambda (cps box)
(with-cps cps
(build-term
($continue k src ($primcall 'box-ref (box))))))))
(define (builtin-ref idx k src)
(let-fresh () (idx-var)
(build-cps-term
($letconst (('idx idx-var idx))
($continue k src
($primcall 'builtin-ref (idx-var)))))))
(define (builtin-ref cps idx k src)
(with-cps cps
($ (with-cps-constants ((idx idx))
(build-term
($continue k src ($primcall 'builtin-ref (idx))))))))
(define (reify-clause ktail)
(let-fresh (kclause kbody kthrow) (wna false str eol throw)
(build-cps-cont
(kclause ($kclause ('() '() #f '() #f)
(kbody
($kargs () ()
($letconst (('wna wna 'wrong-number-of-args)
('false false #f)
('str str "Wrong number of arguments")
('eol eol '()))
($letk ((kthrow
($kargs ('throw) (throw)
($continue ktail #f
($call throw
(wna false str eol false))))))
,(primitive-ref 'throw kthrow #f)))))
,#f)))))
(define (reify-clause cps ktail)
(with-cps cps
(letv throw)
(let$ throw-body
(with-cps-constants ((wna 'wrong-number-of-args)
(false #f)
(str "Wrong number of arguments")
(eol '()))
(build-term
($continue ktail #f
($call throw (wna false str eol false))))))
(letk kthrow ($kargs ('throw) (throw) ,throw-body))
(let$ body (primitive-ref 'throw kthrow #f))
(letk kbody ($kargs () () ,body))
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
kclause))
(define (reify-primitives/1 fun single-value-conts)
(define (visit-clause cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-clause alternate)))))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs (name) (var) body))
,(begin
(bitvector-set! single-value-conts label #t)
(build-cps-cont
(label ($kargs (name) (var) ,(visit-term body))))))
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont)
,cont)))
(define (visit-term term)
(match term
(($ $letk conts body)
;; Visit continuations before their uses.
(let ((conts (map visit-cont conts)))
(build-cps-term
($letk ,conts ,(visit-term body)))))
(($ $continue k src exp)
(match exp
(($ $prim name)
(if (bitvector-ref single-value-conts k)
(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k src)))
(else (primitive-ref name k src)))
(build-cps-term ($continue k src
($const *unspecified*)))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
term)
(else
(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k* src)))
(else (primitive-ref name k* src)))))))))
(_ term)))))
;; A $kreceive continuation should have only one predecessor.
(define (uniquify-receive cps k)
(match (intmap-ref cps k)
(($ $kreceive ($ $arity req () rest () #f) kargs)
(with-cps cps
(letk k ($kreceive req rest kargs))
k))
(_
(with-cps cps k))))
(rewrite-cps-cont fun
(($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
;; A case-lambda with no clauses. Reify a clause.
(label ($kfun src meta self ,tail ,(reify-clause ktail))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail ,(visit-clause clause))))))
(define (reify-primitives cps)
(define (visit-cont label cont cps)
(define (resolve-prim cps name k src)
(cond
((builtin-name->index name)
=> (lambda (idx) (builtin-ref cps idx k src)))
(else
(primitive-ref cps name k src))))
(match cont
(($ $kfun src meta self tail #f)
(with-cps cps
(let$ clause (reify-clause tail))
(setk label ($kfun src meta self tail clause))))
(($ $kargs names vars ($ $continue k src ($ $prim name)))
(with-cps cps
(let$ k (uniquify-receive k))
(let$ body (resolve-prim name k src))
(setk label ($kargs names vars ,body))))
(($ $kargs names vars
($ $continue k src ($ $primcall 'call-thunk/no-inline (proc))))
(with-cps cps
(setk label ($kargs names vars ($continue k src ($call proc ()))))))
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(if (or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
cps
(with-cps cps
(letv proc)
(let$ k (uniquify-receive k))
(letk kproc ($kargs ('proc) (proc)
($continue k src ($call proc args))))
(let$ body (resolve-prim name kproc src))
(setk label ($kargs names vars ,body)))))
(($ $kargs names vars ($ $continue k src ($ $call proc args)))
(with-cps cps
(let$ k (uniquify-receive k))
(setk label ($kargs names vars
($continue k src ($call proc args))))))
(($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
(with-cps cps
(let$ k (uniquify-receive k))
(setk label ($kargs names vars
($continue k src ($callk k* proc args))))))
(_ cps)))
(define (reify-primitives term)
(with-fresh-name-state term
(let ((single-value-conts (make-bitvector (label-counter) #f)))
(rewrite-cps-term term
(($ $program procs)
($program ,(map (lambda (cont)
(reify-primitives/1 cont single-value-conts))
procs)))))))
(with-fresh-name-state cps
(persistent-intmap (intmap-fold visit-cont cps cps))))

490
module/language/cps/renumber.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;; Copyright (C) 2013, 2014, 2015 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
@ -27,317 +27,191 @@
(define-module (language cps renumber)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (renumber))
(define* (compute-tail-path-lengths conts kfun preds)
(define (add-lengths labels lengths length)
(intset-fold (lambda (label lengths)
(intmap-add! lengths label length))
labels
lengths))
(define (compute-next labels lengths)
(intset-fold (lambda (label labels)
(fold1 (lambda (pred labels)
(if (intmap-ref lengths pred (lambda (_) #f))
labels
(intset-add! labels pred)))
(intmap-ref preds label)
labels))
labels
empty-intset))
(define (visit labels lengths length)
(let ((lengths (add-lengths labels lengths length)))
(values (compute-next labels lengths) lengths (1+ length))))
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering.
(define (sort-conts k0 conts new-k0 path-lengths)
(let ((next -1))
(let visit ((k k0))
(define (maybe-visit k)
(let ((entry (vector-ref conts k)))
;; Visit the successor if it has not been
;; visited yet.
(when (and entry (not (exact-integer? entry)))
(visit k))))
(define (sort-labels-locally conts k0 path-lengths)
(define (visit-kf-first? kf kt)
;; Visit the successor of a branch with the shortest path length to
;; the tail first, so that if the branches are unsorted, the longer
;; path length will appear first. This will move a loop exit out of
;; a loop.
(let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
(kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
(if kt-len
(or (not kf-len) (< kf-len kt-len)
;; If the path lengths are the same, preserve original
;; order to avoid squirreliness.
(and (= kf-len kt-len) (< kt kf)))
(if kf-len #f (< kt kf)))))
(let ((order '())
(visited empty-intset))
(let visit ((k k0) (order '()) (visited empty-intset))
(define (visit2 k0 k1 order visited)
(let-values (((order visited) (visit k0 order visited)))
(visit k1 order visited)))
(if (intset-ref visited k)
(values order visited)
(let ((visited (intset-add visited k)))
(call-with-values
(lambda ()
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src exp))
(match exp
(($ $prompt escape? tag handler)
(visit2 k handler order visited))
(($ $branch kt)
(if (visit-kf-first? k kt)
(visit2 k kt order visited)
(visit2 kt k order visited)))
(_
(visit k order visited))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
(visit2 kalt kbody order visited)
(visit kbody order visited)))
(($ $kfun src meta self tail clause)
(if clause
(visit2 tail clause order visited)
(visit tail order visited)))
(($ $ktail) (values order visited))))
(lambda (order visited)
;; Add k to the reverse post-order.
(values (cons k order) visited))))))))
(let ((cont (vector-ref conts k)))
;; Clear the cont table entry to mark this continuation as
;; visited.
(vector-set! conts k #f)
(define (compute-renaming conts kfun)
;; labels := old -> new
;; vars := old -> new
(define *next-label* -1)
(define *next-var* -1)
(define (rename-label label labels)
(set! *next-label* (1+ *next-label*))
(intmap-add! labels label *next-label*))
(define (rename-var sym vars)
(set! *next-var* (1+ *next-var*))
(intmap-add! vars sym *next-var*))
(define (rename label labels vars)
(values (rename-label label labels)
(match (intmap-ref conts label)
(($ $kargs names syms exp)
(fold1 rename-var syms vars))
(($ $kfun src meta self tail clause)
(rename-var self vars))
(_ vars))))
(define (maybe-visit-fun kfun labels vars)
(if (intmap-ref labels kfun (lambda (_) #f))
(values labels vars)
(visit-fun kfun labels vars)))
(define (visit-nested-funs k labels vars)
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src ($ $fun kfun)))
(visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $rec names* syms*
(($ $fun kfun) ...))))
(fold2 visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $closure kfun nfree)))
;; Closures with zero free vars get copy-propagated so it's
;; possible to already have visited them.
(maybe-visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $callk kfun)))
;; Well-known functions never have a $closure created for them
;; and are only referenced by their $callk call sites.
(maybe-visit-fun kfun labels vars))
(_ (values labels vars))))
(define (visit-fun kfun labels vars)
(let* ((preds (compute-predecessors conts kfun))
(path-lengths (compute-tail-path-lengths conts kfun preds))
(order (sort-labels-locally conts kfun path-lengths)))
;; First rename locally, then recurse on nested functions.
(let-values (((labels vars) (fold2 rename order labels vars)))
(fold2 visit-nested-funs order labels vars))))
(let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
(values (persistent-intmap labels) (persistent-intmap vars))))
(match cont
(($ $kargs names syms body)
(let lp ((body body))
(match body
(($ $letk conts body) (lp body))
(($ $continue k src exp)
(match exp
(($ $prompt escape? tag handler)
(maybe-visit handler)
(maybe-visit k))
(($ $branch kt)
;; Visit the successor with the shortest path length
;; to the tail first, so that if the branches are
;; unsorted, the longer path length will appear
;; first. This will move a loop exit out of a loop.
(let ((k-len (vector-ref path-lengths k))
(kt-len (vector-ref path-lengths kt)))
(cond
((if kt-len
(or (not k-len)
(< k-len kt-len)
;; If the path lengths are the
;; same, preserve original order
;; to avoid squirreliness.
(and (= k-len kt-len) (< kt k)))
(if k-len #f (< kt k)))
(maybe-visit k)
(maybe-visit kt))
(else
(maybe-visit kt)
(maybe-visit k)))))
(_
(maybe-visit k)))))))
(($ $kreceive arity k) (maybe-visit k))
(($ $kclause arity ($ $cont kbody) alt)
(match alt
(($ $cont kalt) (maybe-visit kalt))
(_ #f))
(maybe-visit kbody))
(($ $kfun src meta self tail clause)
(match clause
(($ $cont kclause) (maybe-visit kclause))
(_ #f)))
(_ #f))
;; Chain this label to the label that will follow it in the sort
;; order, and record this label as the new head of the order.
(vector-set! conts k next)
(set! next k)))
;; Finally traverse the label chain, giving each label its final
;; name.
(let lp ((n new-k0) (head next))
(if (< head 0)
n
(let ((next (vector-ref conts head)))
(vector-set! conts head n)
(lp (1+ n) next))))))
(define (compute-tail-path-lengths preds ktail path-lengths)
(let visit ((k ktail) (length-in 0))
(let ((length (vector-ref path-lengths k)))
(unless (and length (<= length length-in))
(vector-set! path-lengths k length-in)
(let lp ((preds (vector-ref preds k)))
(match preds
(() #t)
((pred . preds)
(visit pred (1+ length-in))
(lp preds))))))))
(define (compute-new-labels-and-vars fun)
(call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
(let ((labels (make-vector (1+ max-label) #f))
(next-label 0)
(vars (make-vector (1+ max-var) #f))
(next-var 0)
(preds (make-vector (1+ max-label) '()))
(path-lengths (make-vector (1+ max-label) #f)))
(define (add-predecessor! pred succ)
(vector-set! preds succ (cons pred (vector-ref preds succ))))
(define (rename! var)
(vector-set! vars var next-var)
(set! next-var (1+ next-var)))
(define (collect-conts fun)
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(vector-set! labels label cont)
(match cont
(($ $kargs names vars body)
(visit-term body label))
(($ $kfun src meta self tail clause)
(visit-cont tail)
(match clause
(($ $cont kclause)
(add-predecessor! label kclause)
(visit-cont clause))
(#f #f)))
(($ $kclause arity (and body ($ $cont kbody)) alternate)
(add-predecessor! label kbody)
(visit-cont body)
(match alternate
(($ $cont kalt)
(add-predecessor! label kalt)
(visit-cont alternate))
(#f #f)))
(($ $kreceive arity kargs)
(add-predecessor! label kargs))
(($ $ktail) #f)))))
(define (visit-term term label)
(match term
(($ $letk conts body)
(let lp ((conts conts))
(unless (null? conts)
(visit-cont (car conts))
(lp (cdr conts))))
(visit-term body label))
(($ $continue k src exp)
(add-predecessor! label k)
(match exp
(($ $branch kt)
(add-predecessor! label kt))
(($ $prompt escape? tag handler)
(add-predecessor! label handler))
(_ #f)))))
(visit-cont fun))
(define (compute-names-in-fun fun)
(define queue '())
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((reachable? (exact-integer? (vector-ref labels label))))
;; This cont is reachable if it was given a number.
;; Otherwise the cont table entry still contains the
;; cont itself; clear it out to indicate that the cont
;; should not be residualized.
(unless reachable?
(vector-set! labels label #f))
(match cont
(($ $kargs names vars body)
(when reachable?
(for-each rename! vars))
(visit-term body reachable?))
(($ $kfun src meta self tail clause)
(unless reachable? (error "entry should be reachable"))
(rename! self)
(visit-cont tail)
(when clause
(visit-cont clause)))
(($ $kclause arity body alternate)
(unless reachable? (error "clause should be reachable"))
(visit-cont body)
(when alternate
(visit-cont alternate)))
(($ $ktail)
(unless reachable?
;; It's possible for the tail to be unreachable,
;; if all paths contify to infinite loops. Make
;; sure we mark as reachable.
(vector-set! labels label next-label)
(set! next-label (1+ next-label))))
(($ $kreceive)
#f))))))
(define (visit-term term reachable?)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body reachable?))
(($ $continue k src ($ $fun body))
(when reachable?
(set! queue (cons body queue))))
(($ $continue k src ($ $rec names syms funs))
(when reachable?
(set! queue (fold (lambda (fun queue)
(match fun
(($ $fun body)
(cons body queue))))
queue
funs))))
(($ $continue) #f)))
(match fun
(($ $cont kfun ($ $kfun src meta self ($ $cont ktail)))
(collect-conts fun)
(compute-tail-path-lengths preds ktail path-lengths)
(set! next-label (sort-conts kfun labels next-label path-lengths))
(visit-cont fun)
(for-each compute-names-in-fun (reverse queue)))
(($ $program conts)
(for-each compute-names-in-fun conts))))
(compute-names-in-fun fun)
(values labels vars next-label next-var)))))
(define (apply-renumbering term labels vars)
(define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
(match arity
(($ $arity req opt rest kw aok?)
(make-$arity req opt rest
(map (match-lambda
((kw kw-name kw-var)
(list kw kw-name (rename kw-var))))
kw)
aok?))))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "internal error -- failed to visit cont")))
(define (visit-conts conts)
(match conts
(() '())
((cont . conts)
(cond
((visit-cont cont)
=> (lambda (cont)
(cons cont (visit-conts conts))))
(else (visit-conts conts))))))
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kfun src meta self tail clause)
(label
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))
(($ $kclause arity body alternate)
(label
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
,(match (visit-conts conts)
(() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
(match exp
((or ($ $const) ($ $prim))
exp)
(($ $closure k nfree)
(build-cps-exp ($closure (relabel k) nfree)))
(($ $fun)
(visit-fun exp))
(($ $rec names vars funs)
(build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $branch kt exp)
(build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(must-visit-cont body)))))
(match term
(($ $cont)
(must-visit-cont term))
(($ $program conts)
(build-cps-term
($program ,(map must-visit-cont conts))))))
(define (renumber term)
(call-with-values (lambda () (compute-new-labels-and-vars term))
(lambda (labels vars nlabels nvars)
(values (apply-renumbering term labels vars) nlabels nvars))))
(define* (renumber conts #:optional (kfun 0))
(let-values (((label-map var-map) (compute-renaming conts kfun)))
(define (rename-label label) (intmap-ref label-map label))
(define (rename-var var) (intmap-ref var-map var))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $closure k nfree)
($closure (rename-label k) nfree))
(($ $fun body)
($fun (rename-label body)))
(($ $rec names vars funs)
($rec names (map rename-var vars) (map rename-exp funs)))
(($ $values args)
($values ,(map rename-var args)))
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name args)
($primcall name ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-arity arity)
(match arity
(($ $arity req opt rest () aok?)
arity)
(($ $arity req opt rest kw aok?)
(match kw
(() arity)
(((kw kw-name kw-var) ...)
(let ((kw (map list kw kw-name (map rename-var kw-var))))
(make-$arity req opt rest kw aok?)))))))
(persistent-intmap
(intmap-fold
(lambda (old-k new-k out)
(intmap-add!
out
new-k
(rewrite-cont (intmap-ref conts old-k)
(($ $kargs names syms ($ $continue k src exp))
($kargs names (map rename-var syms)
($continue (rename-label k) src ,(rename-exp exp))))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k)))
(($ $ktail)
($ktail))
(($ $kfun src meta self tail clause)
($kfun src meta (rename-var self) (rename-label tail)
(and clause (rename-label clause))))
(($ $kclause arity body alternate)
($kclause ,(rename-arity arity) (rename-label body)
(and alternate (rename-label alternate)))))))
label-map
empty-intmap))))

239
module/language/cps/rotate-loops.scm Normal file
View file

@ -0,0 +1,239 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Rotate loops so that they end with conditional jumps, if possible.
;;; The result goes from:
;;;
;;; loop:
;;; if x < 5 goto done;
;;; x = x + 1;
;;; goto loop;
;;; done:
;;;
;;; if x < 5 goto done;
;;; loop:
;;; x = x + 1;
;;; if x < 5 goto done;
;;; done:
;;;
;;; It's more code but there are fewer instructions in the body. Note
;;; that this transformation isn't guaranteed to produce a loop that
;;; ends in a conditional jump, because usually your loop has some state
;;; that it's shuffling around and for now that shuffle is reified with
;;; the test, not the loop header. Alack.
;;;
;;; Implementation-wise, things are complicated by values flowing out of
;;; the loop. We actually perform this transformation only on loops
;;; that have a single exit continuation, so that we define values
;;; flowing out in one place. We rename the loop variables in two
;;; places internally: one for the peeled comparison, and another for
;;; the body. The loop variables' original names are then bound in a
;;; join continuation for use by successor code.
;;;
;;; Code:
(define-module (language cps rotate-loops)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (rotate-loops))
(define (loop-successors scc succs)
(intset-subtract (intset-fold (lambda (label exits)
(intset-union exits (intmap-ref succs label)))
scc empty-intset)
scc))
(define (find-exits scc succs)
(intset-fold (lambda (label exits)
(if (eq? empty-intset
(intset-subtract (intmap-ref succs label) scc))
exits
(intset-add exits label)))
scc
empty-intset))
(define (find-entry scc preds)
(trivial-intset (find-exits scc preds)))
(define (rotate-loop cps entry-label body-labels succs preds back-edges)
(match (intmap-ref cps entry-label)
((and entry-cont
($ $kargs entry-names entry-vars
($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp))))
(let* ((exit-if-true? (intset-ref body-labels entry-kf))
(loop-exits (find-exits body-labels succs))
(exit (if exit-if-true? entry-kt entry-kf))
(new-entry-label (if exit-if-true? entry-kf entry-kt))
(join-label (fresh-label))
(join-cont (build-cont
($kargs entry-names entry-vars
($continue exit entry-src ($values ())))))
(cps (intmap-add! cps join-label join-cont)))
(define (make-fresh-vars)
(map (lambda (_) (fresh-var)) entry-vars))
(define (make-trampoline k src values)
(build-cont ($kargs () () ($continue k src ($values values)))))
(define (replace-exit k trampoline)
(if (eqv? k exit) trampoline k))
(define (rename-exp exp vars)
(define (rename-var var)
(match (list-index entry-vars var)
(#f var)
(idx (list-ref vars idx))))
(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $closure)) ,exp)
(($ $values args)
($values ,(map rename-var args)))
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk k (rename-var proc) ,(map rename-var args)))
(($ $branch kt ($ $values (arg)))
($branch kt ($values ((rename-var arg)))))
(($ $branch kt ($ $primcall name args))
($branch kt ($primcall name ,(map rename-var args))))
(($ $primcall name args)
($primcall name ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) handler))))
(define (attach-trampoline label src names vars args)
(let* ((trampoline-out-label (fresh-label))
(trampoline-out-cont
(make-trampoline join-label src args))
(trampoline-in-label (fresh-label))
(trampoline-in-cont
(make-trampoline new-entry-label src args))
(kf (if exit-if-true? trampoline-in-label trampoline-out-label))
(kt (if exit-if-true? trampoline-out-label trampoline-in-label))
(cont (build-cont
($kargs names vars
($continue kf entry-src
($branch kt ,(rename-exp entry-exp args))))))
(cps (intmap-replace! cps label cont))
(cps (intmap-add! cps trampoline-in-label trampoline-in-cont)))
(intmap-add! cps trampoline-out-label trampoline-out-cont)))
;; Rewrite the targets of the entry branch to go to
;; trampolines. One will pass values out of the loop, and
;; one will pass values into the loop.
(let* ((pre-header-vars (make-fresh-vars))
(body-vars (make-fresh-vars))
(cps (attach-trampoline entry-label entry-src
entry-names pre-header-vars
pre-header-vars))
(new-entry-cont (build-cont
($kargs entry-names body-vars
,(match (intmap-ref cps new-entry-label)
(($ $kargs () () term) term)))))
(cps (intmap-replace! cps new-entry-label new-entry-cont)))
(intset-fold
(lambda (label cps)
(cond
((intset-ref back-edges label)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue _ src exp))
(match (rename-exp exp body-vars)
(($ $values args)
(attach-trampoline label src names vars args))
(exp
(let* ((args (make-fresh-vars))
(bind-label (fresh-label))
(edge* (build-cont
($kargs names vars
($continue bind-label src ,exp))))
(cps (intmap-replace! cps label edge*))
;; attach-trampoline uses intmap-replace!.
(cps (intmap-add! cps bind-label #f)))
(attach-trampoline bind-label src
entry-names args args)))))))
((intset-ref loop-exits label)
(match (intmap-ref cps label)
(($ $kargs names vars
($ $continue kf src ($ $branch kt exp)))
(let* ((trampoline-out-label (fresh-label))
(trampoline-out-cont
(make-trampoline join-label src body-vars))
(kf (if (eqv? kf exit) trampoline-out-label kf))
(kt (if (eqv? kt exit) trampoline-out-label kt))
(cont (build-cont
($kargs names vars
($continue kf src
($branch kt ,(rename-exp exp body-vars))))))
(cps (intmap-replace! cps label cont)))
(intmap-add! cps trampoline-out-label trampoline-out-cont)))))
(else
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(let ((cont (build-cont
($kargs names vars
($continue k src
,(rename-exp exp body-vars))))))
(intmap-replace! cps label cont)))
(($ $kreceive) cps)))))
(intset-remove body-labels entry-label)
cps))))))
(define (rotate-loops-in-function kfun body cps)
(define (can-rotate? edges)
(intset-fold (lambda (label rotate?)
(match (intmap-ref cps label)
(($ $kreceive) #f)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $branch) #f)
(_ rotate?)))))
edges #t))
(let* ((succs (compute-successors cps kfun))
(preds (invert-graph succs)))
(intmap-fold
(lambda (id scc cps)
(cond
((trivial-intset scc) cps)
((find-entry scc preds)
=> (lambda (entry)
(let ((back-edges (intset-intersect scc
(intmap-ref preds entry))))
(if (and (can-rotate? back-edges)
(trivial-intset
(intset-subtract (intmap-ref succs entry) scc))
(trivial-intset (loop-successors scc succs))
(match (intmap-ref cps entry)
;; Can't rotate $prompt out of loop header.
(($ $kargs _ _ ($ $continue _ _ ($ $prompt))) #f)
(_ #t)))
;; Loop header is an exit, and there is only one
;; exit continuation. Loop header isn't a prompt,
;; so it must be a conditional branch and only one
;; successor is an exit. The values flowing out of
;; the loop are the loop variables.
(rotate-loop cps entry scc succs preds back-edges)
cps))))
(else cps)))
(compute-strongly-connected-components succs kfun)
cps)))
(define (rotate-loops cps)
(persistent-intmap
(with-fresh-name-state cps
(intmap-fold rotate-loops-in-function
(compute-reachable-functions cps)
cps))))

96
module/language/cps/self-references.scm
View file

@ -18,62 +18,62 @@
;;; Commentary:
;;;
;;; A pass that prunes successors of expressions that bail out.
;;; A pass that replaces free references to recursive functions with
;;; bound references.
;;;
;;; Code:
(define-module (language cps self-references)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (resolve-self-references))
(define* (resolve-self-references fun #:optional (env '()))
(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap))
(define (subst var)
(or (assq-ref env var) var))
(intmap-ref env var (lambda (var) var)))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(_ ,cont)))
(define (rename-exp label cps names vars k src exp)
(let ((exp (rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $branch k ($ $values (arg)))
($branch k ($values ((subst arg)))))
(($ $branch k ($ $primcall name args))
($branch k ($primcall name ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))
(intmap-replace! cps label
(build-cont
($kargs names vars ($continue k src ,exp))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $continue k src exp)
($continue k src ,(visit-exp exp)))))
(define (visit-exp exp)
(rewrite-cps-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $fun body)
($fun ,(resolve-self-references body env)))
(($ $rec names vars funs)
($rec names vars (map visit-recursive-fun funs vars)))
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler))))
(define (visit-recursive-fun fun var)
(rewrite-cps-exp fun
(($ $fun (and cont ($ $cont _ ($ $kfun src meta self))))
($fun ,(resolve-self-references cont (acons var self env))))))
(visit-cont fun))
(define (visit-exp cps label names vars k src exp)
(match exp
(($ $fun label)
(resolve-self-references cps label env))
(($ $rec names vars (($ $fun labels) ...))
(fold (lambda (label var cps)
(match (intmap-ref cps label)
(($ $kfun src meta self)
(resolve-self-references cps label
(intmap-add env var self)))))
cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
(intset-fold (lambda (label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp cps label names vars k src exp))
(_ cps)))
(compute-function-body cps label)
cps))

514
module/language/cps/simplify.scm
View file

@ -29,300 +29,246 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps renumber)
#:use-module (language cps utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (simplify))
(define (compute-eta-reductions fun)
(let ((table (make-hash-table)))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body sym syms))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
(when alternate (visit-cont alternate)))
(($ $cont sym _) #f)))
(define (visit-term term term-k term-args)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body term-k term-args))
(($ $continue k src ($ $values args))
(when (and (equal? term-args args) (not (eq? k term-k)))
(hashq-set! table term-k k)))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
(($ $continue k src ($ $rec names syms funs))
(for-each visit-fun funs))
(($ $continue k src _)
#f)))
(define (visit-fun fun)
(match fun
(($ $fun body)
(visit-cont body))))
(visit-cont fun)
table))
(define (intset-maybe-add! set k add?)
(if add? (intset-add! set k) set))
(define (eta-reduce fun)
(let ((table (compute-eta-reductions fun))
(dfg (compute-dfg fun)))
(define (reduce* k scope values?)
(match (hashq-ref table k)
(#f k)
(k*
(if (and (continuation-bound-in? k* scope dfg)
(or values?
(match (lookup-cont k* dfg)
(($ $kargs) #t)
(_ #f))))
(reduce* k* scope values?)
k))))
(define (reduce k scope)
(reduce* k scope #f))
(define (reduce-values k scope)
(reduce* k scope #t))
(define (reduce-const k src scope const)
(let lp ((k k) (seen '()) (const const))
(match (lookup-cont k dfg)
(($ $kargs (_) (arg) term)
(match (find-call term)
(($ $continue k* src* ($ $values (arg*)))
(and (eqv? arg arg*)
(not (memq k* seen))
(lp k* (cons k seen) const)))
(($ $continue k* src* ($ $primcall 'not (arg*)))
(and (eqv? arg arg*)
(not (memq k* seen))
(lp k* (cons k seen) (not const))))
(($ $continue k* src* ($ $branch kt ($ $values (arg*))))
(and (eqv? arg arg*)
(let ((k* (if const kt k*)))
(and (continuation-bound-in? k* scope dfg)
(build-cps-term
($continue k* src ($values ())))))))
(_
(and (continuation-bound-in? k scope dfg)
(build-cps-term
($continue k src ($const const)))))))
(_ #f))))
(define (visit-cont cont scope)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail
,(and clause (visit-cont clause sym)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body sym)
,(and alternate (visit-cont alternate sym)))))
(($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
(sym ($kreceive req rest (reduce kargs scope))))))
(define (visit-term term scope)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map (cut visit-cont <> scope) conts)
,(visit-term body scope)))
(($ $continue k src ($ $values args))
($continue (reduce-values k scope) src ($values args)))
(($ $continue k src (and fun ($ $fun)))
($continue (reduce k scope) src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue k src ($ $const const))
,(let ((k (reduce k scope)))
(or (reduce-const k src scope const)
(build-cps-term ($continue k src ($const const))))))
(($ $continue k src exp)
($continue (reduce k scope) src ,exp))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(visit-cont body #f)))))
(visit-cont fun #f)))
(define (intset-add*! set k*)
(fold1 (lambda (k set) (intset-add! set k)) k* set))
(define (compute-beta-reductions fun)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only be
;; inlined if it is used only once, and not recursively.
(let ((var-table (make-hash-table))
(k-table (make-hash-table))
(dfg (compute-dfg fun)))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body))
(($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
(when alternate (visit-cont alternate)))
(($ $cont sym (or ($ $ktail) ($ $kreceive)))
#f)))
(define (visit-term term)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body))
(($ $continue k src ($ $values args))
(match (lookup-cont k dfg)
(($ $kargs names syms body)
(match (lookup-predecessors k dfg)
((_)
;; There is only one use, and it is this use. We assume
;; it's not recursive, as there would to be some other
;; use for control flow to reach this loop. Store the k
;; -> body mapping in the table. Also store the
;; substitutions for the variables bound by the inlined
;; continuation.
(for-each (cut hashq-set! var-table <> <>) syms args)
(hashq-set! k-table k body))
(_ #f)))
(_ #f)))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
(($ $continue k src ($ $rec names syms funs))
(for-each visit-fun funs))
(($ $continue k src _)
#f)))
(define (visit-fun fun)
(match fun
(($ $fun body)
(visit-cont body))))
(visit-cont fun)
(values var-table k-table)))
(define (fold2* f l1 l2 seed)
(let lp ((l1 l1) (l2 l2) (seed seed))
(match (cons l1 l2)
((() . ()) seed)
(((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
(define (beta-reduce fun)
(let-values (((var-table k-table) (compute-beta-reductions fun)))
(define (subst var)
(cond ((hashq-ref var-table var) => subst)
(else var)))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "continuation must not be inlined" cont)))
(define (visit-cont cont)
(match cont
(($ $cont sym cont)
(and (not (hashq-ref k-table sym))
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
(($ $kfun src meta self tail clause)
(sym ($kfun src meta self ,tail
,(and clause (must-visit-cont clause)))))
(($ $kclause arity body alternate)
(sym ($kclause ,arity ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive)
(sym ,cont)))))))
(define (visit-term term)
(match term
(($ $letk conts body)
(match (filter-map visit-cont conts)
(() (visit-term body))
(conts (build-cps-term
($letk ,conts ,(visit-term body))))))
(($ $continue k src exp)
(cond
((hashq-ref k-table k) => visit-term)
(else
(build-cps-term ($continue k src ,(visit-exp exp))))))))
(define (visit-exp exp)
(match exp
((or ($ $const) ($ $prim)) exp)
(($ $fun) (visit-fun exp))
(($ $rec names syms funs)
(build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
(($ $call proc args)
(let ((args (map subst args)))
(build-cps-exp ($call (subst proc) args))))
(($ $callk k proc args)
(let ((args (map subst args)))
(build-cps-exp ($callk k (subst proc) args))))
(($ $primcall name args)
(let ((args (map subst args)))
(build-cps-exp ($primcall name args))))
(($ $values args)
(let ((args (map subst args)))
(build-cps-exp ($values args))))
(($ $branch kt exp)
(build-cps-exp ($branch kt ,(visit-exp exp))))
(($ $prompt escape? tag handler)
(build-cps-exp ($prompt escape? (subst tag) handler)))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(must-visit-cont body)))))
(must-visit-cont fun)))
(define (transform-conts f conts)
(persistent-intmap
(intmap-fold (lambda (k v out)
(let ((v* (f k v)))
(cond
((equal? v v*) out)
(v* (intmap-replace! out k v*))
(else (intmap-remove out k)))))
conts
conts)))
;; Rewrite the scope tree to reflect the dominator tree. Precondition:
;; the fun has been renumbered, its min-label is 0, and its labels are
;; packed.
(define (redominate fun)
(let* ((dfg (compute-dfg fun))
(idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
(doms (compute-dom-edges idoms 0)))
(define (visit-fun-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail
,(and clause (visit-fun-cont clause)))))
(($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
(label ($kclause ,arity ,(visit-cont kbody body)
,(and alternate (visit-fun-cont alternate)))))))
(define (compute-singly-referenced-vars conts)
(define (visit label cont single multiple)
(define (add-ref var single multiple)
(if (intset-ref single var)
(values single (intset-add! multiple var))
(values (intset-add! single var) multiple)))
(define (ref var) (add-ref var single multiple))
(define (ref* vars) (fold2 add-ref vars single multiple))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
(values single multiple))
(($ $call proc args)
(ref* (cons proc args)))
(($ $callk k proc args)
(ref* (cons proc args)))
(($ $primcall name args)
(ref* args))
(($ $values args)
(ref* args))
(($ $branch kt ($ $values (var)))
(ref var))
(($ $branch kt ($ $primcall name args))
(ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold visit conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (visit-cont label cont)
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names vars ,(visit-term body label))))
(_ (label ,cont))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(visit-fun-cont body)))))
(define (visit-exp k src exp)
(rewrite-cps-term exp
(($ $fun body)
($continue k src ,(visit-fun exp)))
(($ $rec names syms funs)
($continue k src ($rec names syms (map visit-fun funs))))
;;; Continuations whose values are simply forwarded to another and not
;;; used in any other way may be elided via eta reduction over labels.
;;;
;;; There is an exception however: we must exclude strongly-connected
;;; components (SCCs). The only kind of SCC we can build out of $values
;;; expressions are infinite loops.
;;;
;;; Condition A below excludes single-node SCCs. Single-node SCCs
;;; cannot be reduced.
;;;
;;; Condition B conservatively excludes edges to labels already marked
;;; as candidates. This prevents back-edges and so breaks SCCs, and is
;;; optimal if labels are sorted. If the labels aren't sorted it's
;;; suboptimal but cheap.
(define (compute-eta-reductions conts kfun singly-used)
(define (singly-used? vars)
(match vars
(() #t)
((var . vars)
(and (intset-ref singly-used var) (singly-used? vars)))))
(define (visit-fun kfun body eta)
(define (visit-cont label eta)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src ($ $values vars)))
(intset-maybe-add! eta label
(match (intmap-ref conts k)
(($ $kargs)
(and (not (eqv? label k)) ; A
(not (intset-ref eta label)) ; B
(singly-used? vars)))
(_ #f))))
(_
($continue k src ,exp))))
eta)))
(intset-fold visit-cont body eta))
(persistent-intset
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)
empty-intset)))
(define (visit-term term label)
(define (visit-dom-conts label)
(let ((cont (lookup-cont label dfg)))
(match cont
(($ $ktail) '())
(($ $kargs) (list (visit-cont label cont)))
(else
(cons (visit-cont label cont)
(visit-dom-conts* (vector-ref doms label)))))))
(define (eta-reduce conts kfun)
(let* ((singly-used (compute-singly-referenced-vars conts))
(label-set (compute-eta-reductions conts kfun singly-used)))
;; Replace any continuation to a label in LABEL-SET with the label's
;; continuation. The label will denote a $kargs continuation, so
;; only terms that can continue to $kargs need be taken into
;; account.
(define (subst label)
(if (intset-ref label-set label)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k)) (subst k)))
label))
(transform-conts
(lambda (label cont)
(and (not (intset-ref label-set label))
(rewrite-cont cont
(($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
($kargs names syms
($continue (subst kf) src ($branch (subst kt) ,exp))))
(($ $kargs names syms ($ $continue k src ($ $const val)))
,(match (intmap-ref conts k)
(($ $kargs (_)
((? (lambda (var) (intset-ref singly-used var))
var))
($ $continue kf _ ($ $branch kt ($ $values (var)))))
(build-cont
($kargs names syms
($continue (subst (if val kt kf)) src ($values ())))))
(_
(build-cont
($kargs names syms
($continue (subst k) src ($const val)))))))
(($ $kargs names syms ($ $continue k src exp))
($kargs names syms
($continue (subst k) src ,exp)))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (subst k)))
(($ $kclause arity body alt)
($kclause ,arity (subst body) alt))
(_ ,cont))))
conts)))
(define (visit-dom-conts* labels)
(match labels
(() '())
((label . labels)
(append (visit-dom-conts label)
(visit-dom-conts* labels)))))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(rewrite-cps-term term
(($ $letk conts body)
,(visit-term body label))
(($ $continue k src exp)
,(let ((conts (visit-dom-conts* (vector-ref doms label))))
(if (null? conts)
(visit-exp k src exp)
(build-cps-term
($letk ,conts ,(visit-exp k src exp))))))))
(define (compute-beta-reductions conts kfun)
(define (visit-fun kfun body beta)
(let ((single (compute-singly-referenced-labels conts body)))
(define (visit-cont label beta)
(match (intmap-ref conts label)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only
;; be inlined if it is used only once, and not recursively.
(($ $kargs _ _ ($ $continue k src ($ $values)))
(intset-maybe-add! beta label
(and (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs) #t)
(_ #f)))))
(_
beta)))
(intset-fold visit-cont body beta)))
(persistent-intset
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)
empty-intset)))
(visit-fun-cont fun)))
(define (compute-beta-var-substitutions conts label-set)
(define (add-var-substs label var-map)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k _ ($ $values vals)))
(match (intmap-ref conts k)
(($ $kargs names vars)
(fold2* (lambda (var val var-map)
(intmap-add! var-map var val))
vars vals var-map))))))
(intset-fold add-var-substs label-set empty-intmap))
(define (simplify fun)
;; Renumbering prunes continuations that are made unreachable by
;; eta/beta reductions.
(redominate (renumber (eta-reduce (beta-reduce fun)))))
(define (beta-reduce conts kfun)
(let* ((label-set (compute-beta-reductions conts kfun))
(var-map (compute-beta-var-substitutions conts label-set)))
(define (subst var)
(match (intmap-ref var-map var (lambda (_) #f))
(#f var)
(val (subst val))))
(define (transform-exp label k src exp)
(if (intset-ref label-set label)
(match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k* src* exp*))
(transform-exp k k* src* exp*)))
(build-term
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure))
,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $branch kt ($ $values (var)))
($branch kt ($values ((subst var)))))
(($ $branch kt ($ $primcall name args))
($branch kt ($primcall name ,(map subst args))))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))))
(transform-conts
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(build-cont
($kargs names syms ,(transform-exp label k src exp))))
(_ cont)))
conts)))
(define (simplify conts)
(eta-reduce (beta-reduce conts 0) 0))

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

File diff suppressed because it is too large Load diff

26
module/language/cps/spec.scm
View file

@ -1,17 +1,17 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013 Free Software Foundation, Inc.
;; Copyright (C) 2015 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
@ -19,20 +19,34 @@
;;; Code:
(define-module (language cps spec)
#:use-module (ice-9 match)
#:use-module (system base language)
#:use-module (language cps)
#:use-module (language cps intmap)
#:use-module (language cps compile-bytecode)
#:use-module (language cps compile-js)
#:export (cps))
(define (read-cps port env)
(let lp ((out empty-intmap))
(match (read port)
((k exp) (lp (intmap-add! out k (parse-cps exp))))
((? eof-object?)
(if (eq? out empty-intmap)
the-eof-object
(persistent-intmap out))))))
(define* (write-cps exp #:optional (port (current-output-port)))
(write (unparse-cps exp) port))
(intmap-fold (lambda (k cps port)
(write (list k (unparse-cps cps)) port)
(newline port)
port)
exp port))
(define-language cps
#:title "CPS Intermediate Language"
#:reader (lambda (port env) (read port))
#:reader read-cps
#:printer write-cps
#:parser parse-cps
#:compilers `((bytecode . ,compile-bytecode)
(js-il . ,compile-js))
#:for-humans? #f

724
module/language/cps/specialize-numbers.scm Normal file
View file

@ -0,0 +1,724 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2015, 2016 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:
;;;
;;; Some arithmetic operations have multiple implementations: one
;;; polymorphic implementation that works on all kinds of numbers, like
;;; `add', and one or more specialized variants for unboxed numbers of
;;; some kind, like `fadd'. If we can replace a polymorphic
;;; implementation with a monomorphic implementation, we should do so --
;;; it will speed up the runtime and avoid boxing numbers.
;;;
;;; A polymorphic operation can be specialized if its result is
;;; specialized. To specialize an operation, we manually unbox its
;;; arguments and box its return value, relying on CSE to remove boxes
;;; where possible.
;;;
;;; We also want to specialize phi variables. A phi variable is bound
;;; by a continuation with more than one predecessor. For example in
;;; this code:
;;;
;;; (+ 1.0 (if a 2.0 3.0))
;;;
;;; We want to specialize this code to:
;;;
;;; (f64->scm (fl+ (scm->f64 1.0) (if a (scm->f64 2.0) (scm->f64 3.0))))
;;;
;;; Hopefully later passes will remove the conversions. In any case,
;;; specialization will likely result in a lower heap-number allocation
;;; rate, and that cost is higher than the extra opcodes to do
;;; conversions. This transformation is especially important for loop
;;; variables.
;;;
;;; Code:
(define-module (language cps specialize-numbers)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps renumber)
#:use-module (language cps types)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:export (specialize-numbers))
(define (specialize-f64-binop cps k src op a b)
(let ((fop (match op
('add 'fadd)
('sub 'fsub)
('mul 'fmul)
('div 'fdiv))))
(with-cps cps
(letv f64-a f64-b result)
(letk kbox ($kargs ('result) (result)
($continue k src
($primcall 'f64->scm (result)))))
(letk kop ($kargs ('f64-b) (f64-b)
($continue kbox src
($primcall fop (f64-a f64-b)))))
(letk kunbox-b ($kargs ('f64-a) (f64-a)
($continue kop src
($primcall 'scm->f64 (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->f64 (a)))))))
(define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64)
(unbox-b 'scm->u64))
(let ((uop (match op
('add 'uadd)
('sub 'usub)
('mul 'umul)
('logand 'ulogand)
('logior 'ulogior)
('logxor 'ulogxor)
('logsub 'ulogsub)
('rsh 'ursh)
('lsh 'ulsh))))
(with-cps cps
(letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result)
($continue k src
($primcall 'u64->scm (result)))))
(letk kop ($kargs ('u64-b) (u64-b)
($continue kbox src
($primcall uop (u64-a u64-b)))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
($primcall unbox-b (b)))))
(build-term
($continue kunbox-b src
($primcall unbox-a (a)))))))
(define (truncate-u64 cps k src scm)
(with-cps cps
(letv u64)
(letk kbox ($kargs ('u64) (u64)
($continue k src
($primcall 'u64->scm (u64)))))
(build-term
($continue kbox src
($primcall 'scm->u64/truncate (scm))))))
(define (specialize-u64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'u64- op)))
(with-cps cps
(letv u64-a u64-b)
(letk kop ($kargs ('u64-b) (u64-b)
($continue kf src
($branch kt ($primcall op (u64-a u64-b))))))
(letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src
($primcall 'scm->u64 (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->u64 (a)))))))
(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
(let ((op (symbol-append 'u64- op '-scm)))
(with-cps cps
(letv u64)
(letk kop ($kargs ('u64) (u64)
($continue kf src
($branch kt ($primcall op (u64 b-scm))))))
(build-term
($continue kop src
($primcall 'scm->u64 (a-u64)))))))
(define (specialize-f64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'f64- op)))
(with-cps cps
(letv f64-a f64-b)
(letk kop ($kargs ('f64-b) (f64-b)
($continue kf src
($branch kt ($primcall op (f64-a f64-b))))))
(letk kunbox-b ($kargs ('f64-a) (f64-a)
($continue kop src
($primcall 'scm->f64 (b)))))
(build-term
($continue kunbox-b src
($primcall 'scm->f64 (a)))))))
(define (sigbits-union x y)
(and x y (logior x y)))
(define (sigbits-intersect x y)
(cond
((not x) y)
((not y) x)
(else (logand x y))))
(define (sigbits-intersect3 a b c)
(sigbits-intersect a (sigbits-intersect b c)))
(define (next-power-of-two n)
(let lp ((out 1))
(if (< n out)
out
(lp (ash out 1)))))
(define (range->sigbits min max)
(cond
((or (< min 0) (> max #xffffFFFFffffFFFF)) #f)
((eqv? min max) min)
(else (1- (next-power-of-two max)))))
(define (inferred-sigbits types label var)
(call-with-values (lambda () (lookup-pre-type types label var))
(lambda (type min max)
(and (or (eqv? type &exact-integer) (eqv? type &u64))
(range->sigbits min max)))))
(define significant-bits-handlers (make-hash-table))
(define-syntax-rule (define-significant-bits-handler
((primop label types out def ...) arg ...)
body ...)
(hashq-set! significant-bits-handlers 'primop
(lambda (label types out args defs)
(match args ((arg ...) (match defs ((def ...) body ...)))))))
(define-significant-bits-handler ((logand label types out res) a b)
(let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
(inferred-sigbits types label b)
(intmap-ref out res (lambda (_) 0)))))
(intmap-add (intmap-add out a sigbits sigbits-union)
b sigbits sigbits-union)))
(define (significant-bits-handler primop)
(hashq-ref significant-bits-handlers primop))
(define (compute-significant-bits cps types kfun)
"Given the locally inferred types @var{types}, compute a map of VAR ->
BITS indicating the significant bits needed for a variable. BITS may be
#f to indicate all bits, or a non-negative integer indicating a bitmask."
(let ((preds (invert-graph (compute-successors cps kfun))))
(let lp ((worklist (intmap-keys preds)) (visited empty-intset)
(out empty-intmap))
(match (intset-prev worklist)
(#f out)
(label
(let ((worklist (intset-remove worklist label))
(visited* (intset-add visited label)))
(define (continue out*)
(if (and (eq? out out*) (eq? visited visited*))
(lp worklist visited out)
(lp (intset-union worklist (intmap-ref preds label))
visited* out*)))
(define (add-def out var)
(intmap-add out var 0 sigbits-union))
(define (add-defs out vars)
(match vars
(() out)
((var . vars) (add-defs (add-def out var) vars))))
(define (add-unknown-use out var)
(intmap-add out var (inferred-sigbits types label var)
sigbits-union))
(define (add-unknown-uses out vars)
(match vars
(() out)
((var . vars)
(add-unknown-uses (add-unknown-use out var) vars))))
(continue
(match (intmap-ref cps label)
(($ $kfun src meta self)
(add-def out self))
(($ $kargs names vars ($ $continue k src exp))
(let ((out (add-defs out vars)))
(match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec))
;; No uses, so no info added to sigbits.
out)
(($ $values args)
(match (intmap-ref cps k)
(($ $kargs _ vars)
(if (intset-ref visited k)
(fold (lambda (arg var out)
(intmap-add out arg (intmap-ref out var)
sigbits-union))
out args vars)
out))
(($ $ktail)
(add-unknown-uses out args))))
(($ $call proc args)
(add-unknown-use (add-unknown-uses out args) proc))
(($ $callk label proc args)
(add-unknown-use (add-unknown-uses out args) proc))
(($ $branch kt ($ $values (arg)))
(add-unknown-use out arg))
(($ $branch kt ($ $primcall name args))
(add-unknown-uses out args))
(($ $primcall name args)
(let ((h (significant-bits-handler name)))
(if h
(match (intmap-ref cps k)
(($ $kargs _ defs)
(h label types out args defs)))
(add-unknown-uses out args))))
(($ $prompt escape? tag handler)
(add-unknown-use out tag)))))
(_ out)))))))))
(define (specialize-operations cps)
(define (visit-cont label cont cps types sigbits)
(define (operand-in-range? var &type &min &max)
(call-with-values (lambda ()
(lookup-pre-type types label var))
(lambda (type min max)
(and (eqv? type &type) (<= &min min max &max)))))
(define (u64-operand? var)
(operand-in-range? var &exact-integer 0 #xffffffffffffffff))
(define (all-u64-bits-set? var)
(operand-in-range? var &exact-integer
#xffffffffffffffff
#xffffffffffffffff))
(define (only-u64-bits-used? var)
(let ((bits (intmap-ref sigbits var)))
(and bits (= bits (logand bits #xffffFFFFffffFFFF)))))
(define (u64-result? result)
(or (only-u64-bits-used? result)
(call-with-values
(lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(and (eqv? type &exact-integer)
(<= 0 min max #xffffffffffffffff))))))
(define (f64-operands? vara varb)
(let-values (((typea mina maxa) (lookup-pre-type types label vara))
((typeb minb maxb) (lookup-pre-type types label varb)))
(and (zero? (logand (logior typea typeb) (lognot &real)))
(or (eqv? typea &flonum)
(eqv? typeb &flonum)))))
(match cont
(($ $kfun)
(let ((types (infer-types cps label)))
(values cps types (compute-significant-bits cps types label))))
(($ $kargs names vars
($ $continue k src
($ $primcall (and op (or 'add 'sub 'mul 'div)) (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(call-with-values (lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(values
(cond
((eqv? type &flonum)
(with-cps cps
(let$ body (specialize-f64-binop k src op a b))
(setk label ($kargs names vars ,body))))
((and (eqv? type &exact-integer)
(or (<= 0 min max #xffffffffffffffff)
(only-u64-bits-used? result))
(u64-operand? a) (u64-operand? b)
(not (eq? op 'div)))
(with-cps cps
(let$ body (specialize-u64-binop k src op a b))
(setk label ($kargs names vars ,body))))
(else
cps))
types
sigbits))))))
(($ $kargs names vars
($ $continue k src ($ $primcall 'ash (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(call-with-values (lambda ()
(lookup-pre-type types label b))
(lambda (b-type b-min b-max)
(values
(cond
((or (not (u64-result? result))
(not (u64-operand? a))
(not (eqv? b-type &exact-integer))
(< b-min 0 b-max)
(<= b-min -64)
(<= 64 b-max))
cps)
((and (< b-min 0) (= b-min b-max))
(with-cps cps
(let$ body
(with-cps-constants ((bits (- b-min)))
($ (specialize-u64-binop k src 'rsh a bits))))
(setk label ($kargs names vars ,body))))
((< b-min 0)
(with-cps cps
(let$ body
(with-cps-constants ((zero 0))
(letv bits)
(let$ body
(specialize-u64-binop k src 'rsh a bits))
(letk kneg ($kargs ('bits) (bits) ,body))
(build-term
($continue kneg src
($primcall 'sub (zero b))))))
(setk label ($kargs names vars ,body))))
(else
(with-cps cps
(let$ body (specialize-u64-binop k src 'lsh a b))
(setk label ($kargs names vars ,body)))))
types
sigbits))))))
(($ $kargs names vars
($ $continue k src
($ $primcall (and op (or 'logand 'logior 'logsub 'logxor)) (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(values
(cond
((u64-result? result)
;; Given that we know the result can be unboxed to a u64,
;; any out-of-range bits won't affect the result and so we
;; can unconditionally project the operands onto u64.
(cond
((and (eq? op 'logand) (all-u64-bits-set? a))
(with-cps cps
(let$ body (truncate-u64 k src b))
(setk label ($kargs names vars ,body))))
((and (eq? op 'logand) (all-u64-bits-set? b))
(with-cps cps
(let$ body (truncate-u64 k src a))
(setk label ($kargs names vars ,body))))
(else
(with-cps cps
(let$ body (specialize-u64-binop k src op a b
#:unbox-a
'scm->u64/truncate
#:unbox-b
'scm->u64/truncate))
(setk label ($kargs names vars ,body))))))
(else cps))
types sigbits))))
(($ $kargs names vars
($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
(values
(cond
((f64-operands? a b)
(with-cps cps
(let$ body (specialize-f64-comparison k kt src op a b))
(setk label ($kargs names vars ,body))))
((u64-operand? a)
(let ((specialize (if (u64-operand? b)
specialize-u64-comparison
specialize-u64-scm-comparison)))
(with-cps cps
(let$ body (specialize k kt src op a b))
(setk label ($kargs names vars ,body)))))
((u64-operand? b)
(let ((op (match op
('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<))))
(with-cps cps
(let$ body (specialize-u64-scm-comparison k kt src op b a))
(setk label ($kargs names vars ,body)))))
(else cps))
types
sigbits))
(_ (values cps types sigbits))))
(values (intmap-fold visit-cont cps cps #f #f)))
;; Compute a map from VAR -> LABEL, where LABEL indicates the cont that
;; binds VAR.
(define (compute-defs conts labels)
(intset-fold
(lambda (label defs)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(intmap-add defs self label))
(($ $kargs names vars)
(fold1 (lambda (var defs)
(intmap-add defs var label))
vars defs))
(_ defs)))
labels empty-intmap))
;; Compute vars whose definitions are all unboxable and whose uses
;; include an unbox operation.
(define (compute-specializable-vars cps body preds defs
exp-result-unboxable?
unbox-ops)
;; Compute a map of VAR->LABEL... indicating the set of labels that
;; define VAR with unboxable values, given the set of vars
;; UNBOXABLE-VARS which is known already to be unboxable.
(define (collect-unboxable-def-labels unboxable-vars)
(define (add-unboxable-def unboxable-defs var label)
(intmap-add unboxable-defs var (intset label) intset-union))
(intset-fold (lambda (label unboxable-defs)
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k _ exp))
(match exp
((? exp-result-unboxable?)
(match (intmap-ref cps k)
(($ $kargs (_) (def))
(add-unboxable-def unboxable-defs def label))))
(($ $values vars)
(match (intmap-ref cps k)
(($ $kargs _ defs)
(fold
(lambda (var def unboxable-defs)
(if (intset-ref unboxable-vars var)
(add-unboxable-def unboxable-defs def label)
unboxable-defs))
unboxable-defs vars defs))
;; Could be $ktail for $values.
(_ unboxable-defs)))
(_ unboxable-defs)))
(_ unboxable-defs)))
body empty-intmap))
;; Compute the set of vars which are always unboxable.
(define (compute-unboxable-defs)
(fixpoint
(lambda (unboxable-vars)
(intmap-fold
(lambda (def unboxable-pred-labels unboxable-vars)
(if (and (not (intset-ref unboxable-vars def))
;; Are all defining expressions unboxable?
(and-map (lambda (pred)
(intset-ref unboxable-pred-labels pred))
(intmap-ref preds (intmap-ref defs def))))
(intset-add unboxable-vars def)
unboxable-vars))
(collect-unboxable-def-labels unboxable-vars)
unboxable-vars))
empty-intset))
;; Compute the set of vars that may ever be unboxed.
(define (compute-unbox-uses unboxable-defs)
(intset-fold
(lambda (label unbox-uses)
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k _ exp))
(match exp
(($ $primcall (? (lambda (op) (memq op unbox-ops))) (var))
(intset-add unbox-uses var))
(($ $values vars)
(match (intmap-ref cps k)
(($ $kargs _ defs)
(fold (lambda (var def unbox-uses)
(if (intset-ref unboxable-defs def)
(intset-add unbox-uses var)
unbox-uses))
unbox-uses vars defs))
(($ $ktail)
;; Assume return is rare and that any unboxable def can
;; be reboxed when leaving the procedure.
(fold (lambda (var unbox-uses)
(intset-add unbox-uses var))
unbox-uses vars))))
(_ unbox-uses)))
(_ unbox-uses)))
body empty-intset))
(let ((unboxable-defs (compute-unboxable-defs)))
(intset-intersect unboxable-defs (compute-unbox-uses unboxable-defs))))
;; Compute vars whose definitions are all inexact reals and whose uses
;; include an unbox operation.
(define (compute-specializable-f64-vars cps body preds defs)
;; Can the result of EXP definitely be unboxed as an f64?
(define (exp-result-f64? exp)
(match exp
((or ($ $primcall 'f64->scm (_))
($ $const (and (? number?) (? inexact?) (? real?))))
#t)
(_ #f)))
(compute-specializable-vars cps body preds defs exp-result-f64? '(scm->f64)))
;; Compute vars whose definitions are all exact integers in the u64
;; range and whose uses include an unbox operation.
(define (compute-specializable-u64-vars cps body preds defs)
;; Can the result of EXP definitely be unboxed as a u64?
(define (exp-result-u64? exp)
(match exp
((or ($ $primcall 'u64->scm (_))
($ $const (and (? number?) (? exact-integer?)
(? (lambda (n) (<= 0 n #xffffffffffffffff))))))
#t)
(_ #f)))
(compute-specializable-vars cps body preds defs exp-result-u64?
'(scm->u64 'scm->u64/truncate)))
(define (compute-phi-vars cps preds)
(intmap-fold (lambda (label preds phis)
(match preds
(() phis)
((_) phis)
(_
(match (intmap-ref cps label)
(($ $kargs names vars)
(fold1 (lambda (var phis)
(intset-add phis var))
vars phis))
(_ phis)))))
preds empty-intset))
;; Compute the set of variables which have more than one definition,
;; whose definitions are always f64-valued or u64-valued, and which have
;; at least one use that is an unbox operation.
(define (compute-specializable-phis cps body preds defs)
(let ((f64-vars (compute-specializable-f64-vars cps body preds defs))
(u64-vars (compute-specializable-u64-vars cps body preds defs))
(phi-vars (compute-phi-vars cps preds)))
(unless (eq? empty-intset (intset-intersect f64-vars u64-vars))
(error "expected f64 and u64 vars to be disjoint sets"))
(intset-fold (lambda (var out) (intmap-add out var 'u64))
(intset-intersect u64-vars phi-vars)
(intset-fold (lambda (var out) (intmap-add out var 'f64))
(intset-intersect f64-vars phi-vars)
empty-intmap))))
;; Each definition of an f64/u64 variable should unbox that variable.
;; The cont that binds the variable should re-box it under its original
;; name, and rely on CSE to remove the boxing as appropriate.
(define (apply-specialization cps kfun body preds defs phis)
(define (compute-unbox-labels)
(intmap-fold (lambda (phi kind labels)
(fold1 (lambda (pred labels)
(intset-add labels pred))
(intmap-ref preds (intmap-ref defs phi))
labels))
phis empty-intset))
(define (unbox-op var)
(match (intmap-ref phis var)
('f64 'scm->f64)
('u64 'scm->u64)))
(define (box-op var)
(match (intmap-ref phis var)
('f64 'f64->scm)
('u64 'u64->scm)))
(define (unbox-operands)
(define (unbox-arg cps arg def-var have-arg)
(if (intmap-ref phis def-var (lambda (_) #f))
(with-cps cps
(letv unboxed)
(let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term
($continue kunboxed #f ($primcall (unbox-op def-var) (arg)))))
(have-arg cps arg)))
(define (unbox-args cps args def-vars have-args)
(match args
(() (have-args cps '()))
((arg . args)
(match def-vars
((def-var . def-vars)
(unbox-arg cps arg def-var
(lambda (cps arg)
(unbox-args cps args def-vars
(lambda (cps args)
(have-args cps (cons arg args)))))))))))
(intset-fold
(lambda (label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(match (intmap-ref cps k)
(($ $kargs _ defs)
(match exp
;; For expressions that define a single value, we know we need
;; to unbox that value. For $values though we might have to
;; unbox just a subset of values.
(($ $values args)
(with-cps cps
(let$ term (unbox-args
args defs
(lambda (cps args)
(with-cps cps
(build-term
($continue k src ($values args)))))))
(setk label ($kargs names vars ,term))))
(_
(match defs
((def)
(with-cps cps
(letv boxed)
(letk kunbox ($kargs ('boxed) (boxed)
($continue k src
($primcall (unbox-op def) (boxed)))))
(setk label ($kargs names vars
($continue kunbox src ,exp)))))))))))))
(compute-unbox-labels)
cps))
(define (compute-box-labels)
(intmap-fold (lambda (phi kind labels)
(intset-add labels (intmap-ref defs phi)))
phis empty-intset))
(define (box-results cps)
(intset-fold
(lambda (label cps)
(match (intmap-ref cps label)
(($ $kargs names vars term)
(let* ((boxed (fold1 (lambda (var boxed)
(if (intmap-ref phis var (lambda (_) #f))
(intmap-add boxed var (fresh-var))
boxed))
vars empty-intmap))
(bound-vars (map (lambda (var)
(intmap-ref boxed var (lambda (var) var)))
vars)))
(define (box-var cps name var done)
(let ((unboxed (intmap-ref boxed var (lambda (_) #f))))
(if unboxed
(with-cps cps
(let$ term (done))
(letk kboxed ($kargs (name) (var) ,term))
(build-term
($continue kboxed #f
($primcall (box-op var) (unboxed)))))
(done cps))))
(define (box-vars cps names vars done)
(match vars
(() (done cps))
((var . vars)
(match names
((name . names)
(box-var cps name var
(lambda (cps)
(box-vars cps names vars done))))))))
(with-cps cps
(let$ box-term (box-vars names vars
(lambda (cps)
(with-cps cps term))))
(setk label ($kargs names bound-vars ,box-term)))))))
(compute-box-labels)
cps))
(box-results (unbox-operands)))
(define (specialize-phis cps)
(intmap-fold
(lambda (kfun body cps)
(let* ((preds (compute-predecessors cps kfun #:labels body))
(defs (compute-defs cps body))
(phis (compute-specializable-phis cps body preds defs)))
(if (eq? phis empty-intmap)
cps
(apply-specialization cps kfun body preds defs phis))))
(compute-reachable-functions cps)
cps))
(define (specialize-numbers cps)
;; Type inference wants a renumbered graph; OK.
(let ((cps (renumber cps)))
(with-fresh-name-state cps
(specialize-phis (specialize-operations cps)))))

132
module/language/cps/specialize-primcalls.scm
View file

@ -27,81 +27,61 @@
(define-module (language cps specialize-primcalls)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:export (specialize-primcalls))
(define (specialize-primcalls fun)
(let ((dfg (compute-dfg fun #:global? #t)))
(with-fresh-name-state-from-dfg dfg
(define (immediate-u8? sym)
(call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? val)
(and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
($continue k src ($rec names syms (map visit-fun funs))))
(($ $continue k src ($ $primcall name args))
,(visit-primcall k src name args))
(($ $continue)
,term)))
(define (visit-primcall k src name args)
;; If we introduce a VM op from a primcall without a VM op, we
;; will need to ensure that the return arity matches. Rely on the
;; elide-values pass to clean up.
(define-syntax-rule (adapt-void exp)
(let-fresh (k* kvoid) (val)
(build-cps-term
($letk ((k* ($kargs ('val) (val)
($continue k src ($primcall 'values (val)))))
(kvoid ($kargs () ()
($continue k* src ($const *unspecified*)))))
($continue kvoid src exp)))))
(define-syntax-rule (adapt-val exp)
(let-fresh (k*) (val)
(build-cps-term
($letk ((k* ($kargs ('val) (val)
($continue k src ($primcall 'values (val))))))
($continue k* src exp)))))
(match (cons name args)
(('make-vector (? immediate-u8? n) init)
(adapt-val ($primcall 'make-vector/immediate (n init))))
(('vector-ref v (? immediate-u8? n))
(build-cps-term
($continue k src ($primcall 'vector-ref/immediate (v n)))))
(('vector-set! v (? immediate-u8? n) x)
(build-cps-term
($continue k src ($primcall 'vector-set!/immediate (v n x)))))
(('allocate-struct v (? immediate-u8? n))
(adapt-val ($primcall 'allocate-struct/immediate (v n))))
(('struct-ref s (? immediate-u8? n))
(adapt-val ($primcall 'struct-ref/immediate (s n))))
(('struct-set! s (? immediate-u8? n) x)
(build-cps-term
($continue k src ($primcall 'struct-set!/immediate (s n x)))))
(_
(build-cps-term ($continue k src ($primcall name args))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(visit-cont body)))))
(visit-cont fun))))
(define (specialize-primcalls conts)
(let ((constants (compute-constant-values conts)))
(define (u6? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val 63))))
(define (u8? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val 255))))
(define (u64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF))))
(define (s64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val)
(<= (- #x8000000000000000) val #x7fffFFFFffffFFFF))))
(define (f64? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (number? val) (inexact? val) (real? val))))
(define (specialize-primcall name args)
(define (rename name)
(build-exp ($primcall name args)))
(match (cons name args)
(('make-vector (? u8? n) init) (rename 'make-vector/immediate))
(('vector-ref v (? u8? n)) (rename 'vector-ref/immediate))
(('vector-set! v (? u8? n) x) (rename 'vector-set!/immediate))
(('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate))
(('struct-ref s (? u8? n)) (rename 'struct-ref/immediate))
(('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate))
(('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y))))
(('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x))))
(('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y))))
(('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y))))
(('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x))))
(('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y))))
(('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y))))
(('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
(('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y))))
(('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y))))
(('scm->f64 (? f64?)) (rename 'load-f64))
(('scm->u64 (? u64?)) (rename 'load-u64))
(('scm->u64/truncate (? u64?)) (rename 'load-u64))
(('scm->s64 (? s64?)) (rename 'load-s64))
(_ #f)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((exp* (specialize-primcall name args)))
(if exp*
(build-cont
($kargs names vars ($continue k src ,exp*)))
cont)))
(_ cont)))
conts)))

57
module/language/cps2/split-rec.scm → module/language/cps/split-rec.scm
View file

@ -24,12 +24,12 @@
;;;
;;; Code:
(define-module (language cps2 split-rec)
(define-module (language cps split-rec)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 with-cps)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (split-rec))
@ -105,55 +105,6 @@ references."
(persistent-intset defs)))))))
(visit-fun kfun))
(define (intmap-keys map)
(persistent-intset
(intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
(define (compute-sorted-strongly-connected-components edges)
(define nodes
(intmap-keys edges))
;; Add a "start" node that links to all nodes in the graph, and then
;; remove it from the result.
(define components
(intmap-remove
(compute-strongly-connected-components (intmap-add edges 0 nodes) 0)
0))
(define node-components
(intmap-fold (lambda (id nodes out)
(intset-fold (lambda (node out) (intmap-add out node id))
nodes out))
components
empty-intmap))
(define (node-component node)
(intmap-ref node-components node))
(define (component-successors id nodes)
(intset-remove
(intset-fold (lambda (node out)
(intset-fold
(lambda (successor out)
(intset-add out (node-component successor)))
(intmap-ref edges node)
out))
nodes
empty-intset)
id))
(define component-edges
(intmap-map component-successors components))
(define preds
(invert-graph component-edges))
(define roots
(intmap-fold (lambda (id succs out)
(if (eq? empty-intset succs)
(intset-add out id)
out))
component-edges
empty-intset))
;; As above, add a "start" node that links to the roots, and remove it
;; from the result.
(match (compute-reverse-post-order (intmap-add preds 0 roots) 0)
((0 . ids)
(map (lambda (id) (intmap-ref components id)) ids))))
(define (compute-split fns free-vars)
(define (get-free kfun)
;; It's possible for a fun to have been skipped by

72
module/language/cps/type-checks.scm Normal file
View file

@ -0,0 +1,72 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; This pass kills dead expressions: code that has no side effects, and
;;; whose value is unused. It does so by marking all live values, and
;;; then discarding other values as dead. This happens recursively
;;; through procedures, so it should be possible to elide dead
;;; procedures as well.
;;;
;;; Code:
(define-module (language cps type-checks)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps effects-analysis)
#:use-module (language cps types)
#:use-module (language cps intmap)
#:export (elide-type-checks
compute-effects/elide-type-checks))
(define (elide-type-checks conts kfun effects)
"Elide &type-check effects from EFFECTS for the function starting at
KFUN where we can prove that no assertion will be raised at run-time."
(let ((types (infer-types conts kfun)))
(define (visit-primcall effects fx label name args)
(if (primcall-types-check? types label name args)
(intmap-replace! effects label (logand fx (lognot &type-check)))
effects))
(persistent-intmap
(intmap-fold (lambda (label types effects)
(let ((fx (intmap-ref effects label)))
(cond
((causes-all-effects? fx) effects)
((causes-effect? fx &type-check)
(match (intmap-ref conts label)
(($ $kargs _ _ exp)
(match exp
(($ $continue k src ($ $primcall name args))
(visit-primcall effects fx label name args))
(($ $continue k src
($ $branch _ ($primcall name args)))
(visit-primcall effects fx label name args))
(_ effects)))
(_ effects)))
(else effects))))
types
effects))))
(define (compute-effects/elide-type-checks conts)
(intmap-fold (lambda (label cont effects)
(match cont
(($ $kfun) (elide-type-checks conts label effects))
(_ effects)))
conts
(compute-effects conts)))

502
module/language/cps/type-fold.scm
View file

@ -26,9 +26,12 @@
(define-module (language cps type-fold)
#:use-module (ice-9 match)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps utils)
#:use-module (language cps renumber)
#:use-module (language cps types)
#:use-module (language cps with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system base target)
#:export (type-fold))
@ -88,10 +91,11 @@
(else
(values #f #f))))
(define-branch-folder-alias eqv? eq?)
(define-branch-folder-alias equal? eq?)
(define (compare-ranges type0 min0 max0 type1 min1 max1)
(and (zero? (logand (logior type0 type1) (lognot &real)))
;; Since &real, &u64, and &f64 are disjoint, we can compare once
;; against their mask instead of doing three "or" comparisons.
(and (zero? (logand (logior type0 type1) (lognot (logior &real &f64 &u64))))
(cond ((< max0 min1) '<)
((> min0 max1) '>)
((= min0 max0 min1 max1) '=)
@ -104,30 +108,45 @@
((<) (values #t #t))
((= >= >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-< <)
(define-branch-folder-alias u64-<-scm <)
;; We currently cannot define branch folders for floating point
;; comparison ops like the commented one below because we can't prove
;; there are no nans involved.
;;
;; (define-branch-folder-alias f64-< <)
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((< <= =) (values #t #t))
((>) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-<= <=)
(define-branch-folder-alias u64-<=-scm <=)
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
((< >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-= =)
(define-branch-folder-alias u64-=-scm =)
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((> >= =) (values #t #t))
((<) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64->= >=)
(define-branch-folder-alias u64->=-scm >=)
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((>) (values #t #t))
((= <= <) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-> >)
(define-branch-folder-alias u64->-scm >)
(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
(define (logand-min a b)
@ -152,124 +171,137 @@
(define-syntax-rule (define-primcall-reducer name f)
(hashq-set! *primcall-reducers* 'name f))
(define-syntax-rule (define-unary-primcall-reducer (name dfg k src
arg type min max)
(define-syntax-rule (define-unary-primcall-reducer (name cps k src
arg type min max)
body ...)
(define-primcall-reducer name
(lambda (dfg k src arg type min max) body ...)))
(lambda (cps k src arg type min max)
body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name dfg k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define-syntax-rule (define-binary-primcall-reducer (name cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
body ...)
(define-primcall-reducer name
(lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
(lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1)
body ...)))
(define-binary-primcall-reducer (mul dfg k src
(define-binary-primcall-reducer (mul cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (fail) (with-cps cps #f))
(define (negate arg)
(let-fresh (kzero) (zero)
(build-cps-term
($letk ((kzero ($kargs (#f) (zero)
($continue k src ($primcall 'sub (zero arg))))))
($continue kzero src ($const 0))))))
(with-cps cps
($ (with-cps-constants ((zero 0))
(build-term
($continue k src ($primcall 'sub (zero arg))))))))
(define (zero)
(build-cps-term ($continue k src ($const 0))))
(with-cps cps
(build-term ($continue k src ($const 0)))))
(define (identity arg)
(build-cps-term ($continue k src ($values (arg)))))
(with-cps cps
(build-term ($continue k src ($values (arg))))))
(define (double arg)
(build-cps-term ($continue k src ($primcall 'add (arg arg)))))
(with-cps cps
(build-term ($continue k src ($primcall 'add (arg arg))))))
(define (power-of-two constant arg)
(let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(let-fresh (kbits) (bits)
(build-cps-term
($letk ((kbits ($kargs (#f) (bits)
($continue k src ($primcall 'ash (arg bits))))))
($continue kbits src ($const n)))))))
(with-cps cps
($ (with-cps-constants ((bits n))
(build-term ($continue k src ($primcall 'ash (arg bits)))))))))
(define (mul/constant constant constant-type arg arg-type)
(and (or (= constant-type &exact-integer) (= constant-type arg-type))
(case constant
;; (* arg -1) -> (- 0 arg)
((-1) (negate arg))
;; (* arg 0) -> 0 if arg is not a flonum or complex
((0) (and (= constant-type &exact-integer)
(zero? (logand arg-type
(lognot (logior &flonum &complex))))
(zero)))
;; (* arg 1) -> arg
((1) (identity arg))
;; (* arg 2) -> (+ arg arg)
((2) (double arg))
(else (and (= constant-type arg-type &exact-integer)
(positive? constant)
(zero? (logand constant (1- constant)))
(power-of-two constant arg))))))
(cond
((not (or (= constant-type &exact-integer) (= constant-type arg-type)))
(fail))
((eqv? constant -1)
;; (* arg -1) -> (- 0 arg)
(negate arg))
((eqv? constant 0)
;; (* arg 0) -> 0 if arg is not a flonum or complex
(and (= constant-type &exact-integer)
(zero? (logand arg-type
(lognot (logior &flonum &complex))))
(zero)))
((eqv? constant 1)
;; (* arg 1) -> arg
(identity arg))
((eqv? constant 2)
;; (* arg 2) -> (+ arg arg)
(double arg))
((and (= constant-type arg-type &exact-integer)
(positive? constant)
(zero? (logand constant (1- constant))))
;; (* arg power-of-2) -> (ash arg (log2 power-of-2
(power-of-two constant arg))
(else
(fail))))
(cond
((logtest (logior type0 type1) (lognot &number)) #f)
((logtest (logior type0 type1) (lognot &number)) (fail))
((= min0 max0) (mul/constant min0 type0 arg1 type1))
((= min1 max1) (mul/constant min1 type1 arg0 type0))
(else #f)))
(else (fail))))
(define-binary-primcall-reducer (logbit? dfg k src
(define-binary-primcall-reducer (logbit? cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (convert-to-logtest bool-term)
(let-fresh (kt kf kmask kbool) (mask bool)
(build-cps-term
($letk ((kt ($kargs () ()
($continue kbool src ($const #t))))
(kf ($kargs () ()
($continue kbool src ($const #f))))
(kbool ($kargs (#f) (bool)
,(bool-term bool)))
(kmask ($kargs (#f) (mask)
($continue kf src
($branch kt ($primcall 'logtest (mask arg1)))))))
,(if (eq? min0 max0)
($continue kmask src ($const (ash 1 min0)))
(let-fresh (kone) (one)
(build-cps-term
($letk ((kone ($kargs (#f) (one)
($continue kmask src
($primcall 'ash (one arg0))))))
($continue kone src ($const 1))))))))))
(define (convert-to-logtest cps kbool)
(define (compute-mask cps kmask src)
(if (eq? min0 max0)
(with-cps cps
(build-term
($continue kmask src ($const (ash 1 min0)))))
(with-cps cps
($ (with-cps-constants ((one 1))
(build-term
($continue kmask src ($primcall 'ash (one arg0)))))))))
(with-cps cps
(letv mask)
(letk kt ($kargs () ()
($continue kbool src ($const #t))))
(letk kf ($kargs () ()
($continue kbool src ($const #f))))
(letk kmask ($kargs (#f) (mask)
($continue kf src
($branch kt ($primcall 'logtest (mask arg1))))))
($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall.
(let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
(and (= type0 &exact-integer)
(<= 0 min0 positive-fixnum-bits)
(<= 0 max0 positive-fixnum-bits)
(match (lookup-cont k dfg)
(($ $kreceive arity kargs)
(match arity
(($ $arity (_) () (not #f) () #f)
(convert-to-logtest
(lambda (bool)
(let-fresh (knil) (nil)
(build-cps-term
($letk ((knil ($kargs (#f) (nil)
($continue kargs src
($values (bool nil))))))
($continue knil src ($const '()))))))))
(_
(convert-to-logtest
(lambda (bool)
(build-cps-term
($continue k src ($primcall 'values (bool)))))))))
(($ $ktail)
(convert-to-logtest
(lambda (bool)
(build-cps-term
($continue k src ($primcall 'return (bool)))))))))))
(if (and (= type0 &exact-integer)
(<= 0 min0 positive-fixnum-bits)
(<= 0 max0 positive-fixnum-bits))
(match (intmap-ref cps k)
(($ $kreceive arity kargs)
(match arity
(($ $arity (_) () (not #f) () #f)
(with-cps cps
(letv bool)
(let$ body (with-cps-constants ((nil '()))
(build-term
($continue kargs src ($values (bool nil))))))
(letk kbool ($kargs (#f) (bool) ,body))
($ (convert-to-logtest kbool))))
(_
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'values (bool)))))
($ (convert-to-logtest kbool))))))
(($ $ktail)
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($values (bool)))))
($ (convert-to-logtest kbool)))))
(with-cps cps #f))))
;;
(define (fold-and-reduce fun dfg min-label min-var)
(define (local-type-fold start end cps)
(define (scalar-value type val)
(cond
((eqv? type &exact-integer) val)
@ -281,163 +313,143 @@
((eqv? type &nil) #nil)
((eqv? type &null) '())
(else (error "unhandled type" type val))))
(let* ((typev (infer-types fun dfg))
(label-count ((make-local-cont-folder label-count)
(lambda (k cont label-count) (1+ label-count))
fun 0))
(folded? (make-bitvector label-count #f))
(folded-values (make-vector label-count #f))
(reduced-terms (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
(define (var->idx var) (- var min-var))
(define (maybe-reduce-primcall! label k src name args)
(let* ((reducer (hashq-ref *primcall-reducers* name)))
(when reducer
(vector-set!
reduced-terms
(label->idx label)
(match args
((arg0)
(call-with-values (lambda () (lookup-pre-type typev label arg0))
(lambda (type0 min0 max0)
(reducer dfg k src arg0 type0 min0 max0))))
((arg0 arg1)
(call-with-values (lambda () (lookup-pre-type typev label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type typev label arg1))
(lambda (type1 min1 max1)
(reducer dfg k src arg0 type0 min0 max0
arg1 type1 min1 max1))))))
(_ #f))))))
(define (maybe-fold-value! label name def)
(call-with-values (lambda () (lookup-post-type typev label def 0))
(let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src name args def)
(call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max)
(cond
((and (not (zero? type))
(zero? (logand type (1- type)))
(zero? (logand type (lognot &scalar-types)))
(eqv? min max))
(bitvector-set! folded? (label->idx label) #t)
(vector-set! folded-values (label->idx label)
(scalar-value type min))
#t)
(else #f)))))
(define (maybe-fold-unary-branch! label name arg)
(let* ((folder (hashq-ref *branch-folders* name)))
(when folder
(call-with-values (lambda () (lookup-pre-type typev label arg))
(lambda (type min max)
(call-with-values (lambda () (folder type min max))
(lambda (f? v)
(bitvector-set! folded? (label->idx label) f?)
(vector-set! folded-values (label->idx label) v))))))))
(define (maybe-fold-binary-branch! label name arg0 arg1)
(let* ((folder (hashq-ref *branch-folders* name)))
(when folder
(call-with-values (lambda () (lookup-pre-type typev label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type typev label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1))
(lambda (f? v)
(bitvector-set! folded? (label->idx label) f?)
(vector-set! folded-values (label->idx label) v))))))))))
(define (visit-cont cont)
(match cont
(($ $cont label ($ $kargs _ _ body))
(visit-term body label))
(($ $cont label ($ $kclause arity body alternate))
(visit-cont body)
(visit-cont alternate))
(_ #f)))
(define (visit-term term label)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body label))
(($ $continue k src ($ $primcall name args))
;; We might be able to fold primcalls that define a value.
(match (lookup-cont k dfg)
(($ $kargs (_) (def))
;(pk 'maybe-fold-value src name args)
(unless (maybe-fold-value! label name def)
(maybe-reduce-primcall! label k src name args)))
(_
(maybe-reduce-primcall! label k src name args))))
(($ $continue kf src ($ $branch kt ($ $primcall name args)))
;; We might be able to fold primcalls that branch.
;(pk 'maybe-fold-branch label src name args)
(and (not (zero? type))
(zero? (logand type (1- type)))
(zero? (logand type (lognot &scalar-types)))
(eqv? min max)
(let ((val (scalar-value type min)))
;; (pk 'folded src name args val)
(with-cps cps
(letv v*)
(letk k* ($kargs (#f) (v*)
($continue k src ($const val))))
;; Rely on DCE to elide this expression, if
;; possible.
(setk label
($kargs names vars
($continue k* src ($primcall name args))))))))))
(define (reduce-primcall cps label names vars k src name args)
(and=>
(hashq-ref *primcall-reducers* name)
(lambda (reducer)
(match args
((arg)
(maybe-fold-unary-branch! label name arg))
((arg0)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))
((arg0 arg1)
(maybe-fold-binary-branch! label name arg0 arg1))))
(_ #f)))
(when typev
(match fun
(($ $cont kfun ($ $kfun src meta self tail clause))
(visit-cont clause))))
(values folded? folded-values reduced-terms)))
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0
arg1 type1 min1 max1))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))))
(_ #f)))))
(define (fold-unary-branch cps label names vars kf kt src name arg)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max)
(call-with-values (lambda () (folder type min max))
(lambda (f? v)
;; (when f? (pk 'folded-unary-branch label name arg v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))
(define (fold-binary-branch cps label names vars kf kt src name arg0 arg1)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1))
(lambda (f? v)
;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp)
(match exp
(($ $primcall name args)
;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k)
(($ $kargs (_) (def))
(or (fold-primcall cps label names vars k src name args def)
(reduce-primcall cps label names vars k src name args)
cps))
(_
(or (reduce-primcall cps label names vars k src name args)
cps))))
(($ $branch kt ($ $primcall name args))
;; We might be able to fold primcalls that branch.
(match args
((x)
(or (fold-unary-branch cps label names vars k kt src name x)
cps))
((x y)
(or (fold-binary-branch cps label names vars k kt src name x y)
cps))))
(($ $branch kt ($ $values (arg)))
;; We might be able to fold branches on values.
(call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max)
(cond
((zero? (logand type (logior &false &nil)))
(with-cps cps
(setk label
($kargs names vars ($continue kt src ($values ()))))))
((zero? (logand type (lognot (logior &false &nil))))
(with-cps cps
(setk label
($kargs names vars ($continue k src ($values ()))))))
(else cps)))))
(_ cps)))
(let lp ((label start) (cps cps))
(if (<= label end)
(lp (1+ label)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-expression cps label names vars k src exp))
(_ cps)))
cps))))
(define (fold-constants* fun dfg)
(match fun
(($ $cont min-label ($ $kfun _ _ min-var))
(call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
(lambda (folded? folded-values reduced-terms)
(define (label->idx label) (- label min-label))
(define (var->idx var) (- var min-var))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names syms body))
(label ($kargs names syms ,(visit-term body label))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(_ ,cont)))
(define (visit-term term label)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body label)))
(($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names vars funs))
($continue k src ($rec names vars (map visit-fun funs))))
(($ $continue k src (and primcall ($ $primcall name args)))
,(cond
((bitvector-ref folded? (label->idx label))
(let ((val (vector-ref folded-values (label->idx label))))
;; Uncomment for debugging.
;; (pk 'folded src primcall val)
(let-fresh (k*) (v*)
;; Rely on DCE to elide this expression, if
;; possible.
(build-cps-term
($letk ((k* ($kargs (#f) (v*)
($continue k src ($const val)))))
($continue k* src ,primcall))))))
(else
(or (vector-ref reduced-terms (label->idx label))
term))))
(($ $continue kf src ($ $branch kt ($ $primcall)))
,(if (bitvector-ref folded? (label->idx label))
;; Folded branch.
(let ((val (vector-ref folded-values (label->idx label))))
(build-cps-term
($continue (if val kt kf) src ($values ()))))
term))
(_ ,term)))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun body)
($fun ,(fold-constants* body dfg)))))
(rewrite-cps-cont fun
(($ $cont kfun ($ $kfun src meta self tail clause))
(kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
(define (fold-functions-in-renumbered-program f conts seed)
(let* ((conts (persistent-intmap conts))
(end (1+ (intmap-prev conts))))
(let lp ((label 0) (seed seed))
(if (eqv? label end)
seed
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(lp (1+ tail) (f label tail seed))))))))
(define (type-fold fun)
(let* ((fun (renumber fun))
(dfg (compute-dfg fun)))
(with-fresh-name-state-from-dfg dfg
(fold-constants* fun dfg))))
(define (type-fold conts)
;; Type analysis wants a program whose labels are sorted.
(let ((conts (renumber conts)))
(with-fresh-name-state conts
(persistent-intmap
(fold-functions-in-renumbered-program local-type-fold conts conts)))))

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

File diff suppressed because it is too large Load diff

231
module/language/cps2/utils.scm → module/language/cps/utils.scm
View file

@ -22,11 +22,11 @@
;;;
;;; Code:
(define-module (language cps2 utils)
(define-module (language cps utils)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps2)
#:use-module (language cps)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (;; Fresh names.
@ -37,7 +37,10 @@
;; Various utilities.
fold1 fold2
trivial-intset
intmap-map
intmap-keys
invert-bijection invert-partition
intset->intmap
worklist-fold
fixpoint
@ -45,13 +48,16 @@
;; Flow analysis.
compute-constant-values
compute-function-body
compute-reachable-functions
compute-successors
invert-graph
compute-predecessors
compute-reverse-post-order
compute-strongly-connected-components
compute-sorted-strongly-connected-components
compute-idoms
compute-dom-edges
solve-flow-equations
))
(define label-counter (make-parameter #f))
@ -108,11 +114,38 @@
(lambda (s0 s1)
(lp l s0 s1)))))))
(define (trivial-intset set)
"Returns the sole member of @var{set}, if @var{set} has exactly one
member, or @code{#f} otherwise."
(let ((first (intset-next set)))
(and first
(not (intset-next set (1+ first)))
first)))
(define (intmap-map proc map)
(persistent-intmap
(intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v)))
(intmap-fold (lambda (k v out) (intmap-add! out k (proc k v)))
map
map)))
empty-intmap)))
(define (intmap-keys map)
"Return an intset of the keys in @var{map}."
(persistent-intset
(intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
(define (invert-bijection map)
"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))
(define (invert-partition map)
"Assuming the values of @var{map} are disjoint intsets, compute a map
in which each member of each set maps to its key. If the values are not
disjoint, an error will be signalled."
(intmap-fold (lambda (k v* out)
(intset-fold (lambda (v out) (intmap-add out v k)) v* out))
map empty-intmap))
(define (intset->intmap f set)
(persistent-intmap
@ -149,9 +182,11 @@
(define (compute-defining-expressions conts)
(define (meet-defining-expressions old new)
;; If there are multiple definitions, punt and
;; record #f.
#f)
;; If there are multiple definitions and they are different, punt
;; and record #f.
(if (equal? old new)
old
#f))
(persistent-intmap
(intmap-fold (lambda (label cont defs)
(match cont
@ -165,14 +200,41 @@
empty-intmap)))
(define (compute-constant-values conts)
(persistent-intmap
(intmap-fold (lambda (var exp out)
(match exp
(($ $const val)
(intmap-add! out var val))
(_ out)))
(compute-defining-expressions conts)
empty-intmap)))
(let ((defs (compute-defining-expressions conts)))
(persistent-intmap
(intmap-fold
(lambda (var exp out)
(match exp
(($ $primcall (or 'load-f64 'load-u64 'load-s64) (val))
(intmap-add! out var (intmap-ref out val)))
;; Punch through type conversions to allow uadd to specialize
;; to uadd/immediate.
(($ $primcall 'scm->f64 (val))
(let ((f64 (intmap-ref out val (lambda (_) #f))))
(if (and f64 (number? f64) (inexact? f64) (real? f64))
(intmap-add! out var f64)
out)))
(($ $primcall (or 'scm->u64 'scm->u64/truncate) (val))
(let ((u64 (intmap-ref out val (lambda (_) #f))))
(if (and u64 (number? u64) (exact-integer? u64)
(<= 0 u64 #xffffFFFFffffFFFF))
(intmap-add! out var u64)
out)))
(($ $primcall 'scm->s64 (val))
(let ((s64 (intmap-ref out val (lambda (_) #f))))
(if (and s64 (number? s64) (exact-integer? s64)
(<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
(intmap-add! out var s64)
out)))
(_ out)))
defs
(intmap-fold (lambda (var exp out)
(match exp
(($ $const val)
(intmap-add! out var val))
(_ out)))
defs
empty-intmap)))))
(define (compute-function-body conts kfun)
(persistent-intset
@ -201,7 +263,45 @@
(visit-cont k labels))
(_ labels)))))))))))
(define (compute-successors conts kfun)
(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
$kfun and each associated value is the body of the function, as an
intset."
(define (intset-cons i set) (intset-add set i))
(define (visit-fun kfun body to-visit)
(intset-fold
(lambda (label to-visit)
(define (return kfun*) (fold intset-cons to-visit kfun*))
(define (return1 kfun) (intset-add to-visit kfun))
(define (return0) to-visit)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun label) (return1 label))
(($ $rec _ _ (($ $fun labels) ...)) (return labels))
(($ $closure label nfree) (return1 label))
(($ $callk label) (return1 label))
(_ (return0))))
(_ (return0))))
body
to-visit))
(let lp ((to-visit (intset kfun)) (visited empty-intmap))
(let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
(if (eq? to-visit empty-intset)
visited
(call-with-values
(lambda ()
(intset-fold
(lambda (kfun to-visit visited)
(let ((body (compute-function-body conts kfun)))
(values (visit-fun kfun body to-visit)
(intmap-add visited kfun body))))
to-visit
empty-intset
visited))
lp)))))
(define* (compute-successors conts #:optional (kfun (intmap-next conts)))
(define (visit label succs)
(let visit ((label kfun) (succs empty-intmap))
(define (propagate0)
@ -223,8 +323,8 @@
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(propagate2 clause tail)
(propagate1 tail)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
@ -305,6 +405,58 @@ partitioning the labels into strongly connected components (SCCs)."
(fold visit-scc empty-intmap (compute-reverse-post-order succs start))
empty-intmap)))
(define (compute-sorted-strongly-connected-components edges)
"Given a LABEL->SUCCESSOR... graph, return a list of strongly
connected components in sorted order."
(define nodes
(intmap-keys edges))
;; Add a "start" node that links to all nodes in the graph, and then
;; remove it from the result.
(define start
(if (eq? nodes empty-intset)
0
(1+ (intset-prev nodes))))
(define components
(intmap-remove
(compute-strongly-connected-components (intmap-add edges start nodes)
start)
start))
(define node-components
(intmap-fold (lambda (id nodes out)
(intset-fold (lambda (node out) (intmap-add out node id))
nodes out))
components
empty-intmap))
(define (node-component node)
(intmap-ref node-components node))
(define (component-successors id nodes)
(intset-remove
(intset-fold (lambda (node out)
(intset-fold
(lambda (successor out)
(intset-add out (node-component successor)))
(intmap-ref edges node)
out))
nodes
empty-intset)
id))
(define component-edges
(intmap-map component-successors components))
(define preds
(invert-graph component-edges))
(define roots
(intmap-fold (lambda (id succs out)
(if (eq? empty-intset succs)
(intset-add out id)
out))
component-edges
empty-intset))
;; As above, add a "start" node that links to the roots, and remove it
;; from the result.
(match (compute-reverse-post-order (intmap-add preds start roots) start)
(((? (lambda (id) (eqv? id start))) . ids)
(map (lambda (id) (intmap-ref components id)) ids))))
;; Precondition: For each function in CONTS, the continuation names are
;; topologically sorted.
(define (compute-idoms conts kfun)
@ -353,3 +505,46 @@ partitioning the labels into strongly connected components (SCCs)."
(else (intmap-add! doms idom label snoc)))))
idoms
empty-intmap)))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define* (solve-flow-equations succs in out kill gen subtract add meet
#:optional (worklist (intmap-keys succs)))
"Find a fixed point for flow equations for SUCCS, where INIT is the
initial state at each node in SUCCS. KILL and GEN are intmaps
indicating the state that is killed or defined at every node, and
SUBTRACT, ADD, and MEET operates on that state."
(define (visit label in out)
(let* ((in-1 (intmap-ref in label))
(kill-1 (intmap-ref kill label))
(gen-1 (intmap-ref gen label))
(out-1 (intmap-ref out label))
(out-1* (add (subtract in-1 kill-1) gen-1)))
(if (eq? out-1 out-1*)
(values empty-intset in out)
(let ((out (intmap-replace! out label out-1*)))
(call-with-values
(lambda ()
(intset-fold (lambda (succ in changed)
(let* ((in-1 (intmap-ref in succ))
(in-1* (meet in-1 out-1*)))
(if (eq? in-1 in-1*)
(values in changed)
(values (intmap-replace! in succ in-1*)
(intset-add changed succ)))))
(intmap-ref succs label) in empty-intset))
(lambda (in changed)
(values changed in out)))))))
(let run ((worklist worklist) (in in) (out out))
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist popped)
(if popped
(call-with-values (lambda () (visit popped in out))
(lambda (changed in out)
(run (intset-union worklist changed) in out)))
(values (persistent-intmap in)
(persistent-intmap out)))))))

445
module/language/cps/verify.scm
View file

@ -1,195 +1,304 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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
;;; Diagnostic checker for CPS
;;; Copyright (C) 2014, 2015 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/>.
;;; Commentary:
;;;
;;; A routine to detect invalid CPS.
;;;
;;; Code:
(define-module (language cps verify)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:export (verify-cps))
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps primitives)
#:use-module (srfi srfi-11)
#:export (verify))
(define (verify-cps fun)
(define seen-labels (make-hash-table))
(define seen-vars (make-hash-table))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define (add sym seen env)
(when (hashq-ref seen sym)
(error "duplicate gensym" sym))
(hashq-set! seen sym #t)
(cons sym env))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(define (add-env new seen env)
(if (null? new)
env
(add-env (cdr new) seen (add (car new) seen env))))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define (add-vars new env)
(unless (and-map exact-integer? new)
(error "bad vars" new))
(add-env new seen-vars env))
(define (check-distinct-vars conts)
(define (adjoin-def var seen)
(when (intset-ref seen var)
(error "duplicate var name" seen var))
(intset-add seen var))
(intmap-fold
(lambda (label cont seen)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(fold1 adjoin-def vars seen))
(($ $kfun src meta self tail clause)
(adjoin-def self seen))
(_ seen))
)
conts
empty-intset))
(define (add-labels new env)
(unless (and-map exact-integer? new)
(error "bad labels" new))
(add-env new seen-labels env))
(define (compute-available-definitions conts kfun)
"Compute and return a map of LABEL->VAR..., where VAR... are the
definitions that are available at LABEL."
(define (adjoin-def var defs)
(when (intset-ref defs var)
(error "var already present in defs" defs var))
(intset-add defs var))
(define (check-ref sym seen env)
(cond
((not (hashq-ref seen sym))
(error "unbound lexical" sym))
((not (memq sym env))
(error "displaced lexical" sym))))
(define (propagate defs succ out)
(let* ((in (intmap-ref defs succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() defs)
(values (list succ)
(intmap-add defs succ in* (lambda (old new) new))))))
(define (check-label sym env)
(check-ref sym seen-labels env))
(define (visit-cont label defs)
(let ((in (intmap-ref defs label)))
(define (propagate0 out)
(values '() defs))
(define (propagate1 succ out)
(propagate defs succ out))
(define (propagate2 succ0 succ1 out)
(let*-values (((changed0 defs) (propagate defs succ0 out))
((changed1 defs) (propagate defs succ1 out)))
(values (append changed0 changed1) defs)))
(define (check-var sym env)
(check-ref sym seen-vars env))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let ((out (fold1 adjoin-def vars in)))
(match exp
(($ $branch kt) (propagate2 k kt out))
(($ $prompt escape? tag handler) (propagate2 k handler out))
(_ (propagate1 k out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
(let ((out (adjoin-def self in)))
(if clause
(propagate1 clause out)
(propagate0 out))))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt in)
(propagate1 kbody in)))
(($ $ktail) (propagate0 in)))))
(define (check-src src)
(if (and src (not (and (list? src) (and-map pair? src)
(and-map symbol? (map car src)))))
(error "bad src")))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (visit-cont-body cont k-env v-env)
(match cont
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
(check-label k k-env))
(($ $kargs (name ...) (sym ...) body)
(unless (= (length name) (length sym))
(error "name and sym lengths don't match" name sym))
(visit-term body k-env (add-vars sym v-env)))
(_
;; $kclause, $kfun, and $ktail are only ever seen in $fun.
(error "unexpected cont body" cont))))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
(define (visit-clause clause k-env v-env)
(match clause
(($ $cont kclause
($ $kclause
($ $arity
((? symbol? req) ...)
((? symbol? opt) ...)
(and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) kwsym) ...)
(or #f #t))
($ $cont kbody (and body ($ $kargs names syms _)))
alternate))
(for-each (lambda (sym)
(unless (memq sym syms)
(error "bad keyword sym" sym)))
kwsym)
;; FIXME: It is technically possible for kw syms to alias other
;; syms.
(unless (equal? (append req opt (if rest (list rest) '()) kwname)
names)
(error "clause body names do not match arity names" exp))
(let ((k-env (add-labels (list kclause kbody) k-env)))
(visit-cont-body body k-env v-env))
(when alternate
(visit-clause alternate k-env v-env)))
(_
(error "unexpected clause" clause))))
(define (check-valid-var-uses conts kfun)
(define (adjoin-def var defs) (intset-add defs var))
(let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
(define (visit-exp exp bound first-order)
(define (check-use var)
(unless (intset-ref bound var)
(error "unbound var" var)))
(define (visit-first-order kfun)
(if (intset-ref first-order kfun)
first-order
(visit-fun kfun empty-intset (intset-add first-order kfun))))
(match exp
((or ($ $const) ($ $prim)) first-order)
;; todo: $closure
(($ $fun kfun)
(visit-fun kfun bound first-order))
(($ $closure kfun)
(visit-first-order kfun))
(($ $rec names vars (($ $fun kfuns) ...))
(let ((bound (fold1 adjoin-def vars bound)))
(fold1 (lambda (kfun first-order)
(visit-fun kfun bound first-order))
kfuns first-order)))
(($ $values args)
(for-each check-use args)
first-order)
(($ $call proc args)
(check-use proc)
(for-each check-use args)
first-order)
(($ $callk kfun proc args)
(check-use proc)
(for-each check-use args)
(visit-first-order kfun))
(($ $branch kt ($ $values (arg)))
(check-use arg)
first-order)
(($ $branch kt ($ $primcall name args))
(for-each check-use args)
first-order)
(($ $primcall name args)
(for-each check-use args)
first-order)
(($ $prompt escape? tag handler)
(check-use tag)
first-order)))
(intmap-fold
(lambda (label bound first-order)
(let ((bound (intset-union free bound)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp exp (fold1 adjoin-def vars bound) first-order))
(_ first-order))))
(compute-available-definitions conts kfun)
first-order)))
(define (visit-entry entry k-env v-env)
(match entry
(($ $cont kbody
($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(check-src src)
;; Reset the continuation environment, because Guile's
;; continuations are local.
(let ((v-env (add-vars (list self) v-env))
(k-env (add-labels (list ktail) '())))
(when clause
(visit-clause clause k-env v-env))))
(_ (error "unexpected $kfun" entry))))
(define (check-label-partition conts kfun)
;; A continuation can only belong to one function.
(intmap-fold
(lambda (kfun body seen)
(intset-fold
(lambda (label seen)
(intmap-add seen label kfun
(lambda (old new)
(error "label used by two functions" label old new))))
body
seen))
(compute-reachable-functions conts kfun)
empty-intmap))
(define (visit-fun fun k-env v-env)
(match fun
(($ $fun entry)
(visit-entry entry '() v-env))
(_
(error "unexpected $fun" fun))))
(define (compute-reachable-labels conts kfun)
(intmap-fold (lambda (kfun body seen) (intset-union seen body))
(compute-reachable-functions conts kfun)
empty-intset))
(define (visit-expression exp k-env v-env)
(define (check-arities conts kfun)
(define (check-arity exp cont)
(define (assert-unary)
(match cont
(($ $kargs (_) (_)) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-nullary)
(match cont
(($ $kargs () ()) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-n-ary n)
(match cont
(($ $kargs names vars)
(unless (= (length vars) n)
(error "expected n-ary continuation" n cont)))
(_ (error "expected $kargs continuation" cont))))
(define (assert-kreceive-or-ktail)
(match cont
((or ($ $kreceive) ($ $ktail)) #t)
(_ (error "expected $kreceive or $ktail continuation" cont))))
(match exp
(($ $const val)
#t)
(($ $prim (? symbol? name))
#t)
(($ $closure kfun n)
#t)
(($ $fun)
(visit-fun exp k-env v-env))
(($ $rec (name ...) (sym ...) (fun ...))
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
;; FIXME: syms added in two places (here in $rec versus also in
;; target $kargs)
(let ((v-env (add-vars sym v-env)))
(for-each (cut visit-fun <> k-env v-env) fun)))
(($ $call proc (arg ...))
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
(($ $callk k* proc (arg ...))
;; We don't check that k* is in scope; it's actually inside some
;; other function, probably. We rely on the transformation that
;; introduces the $callk to be correct, and the linker to resolve
;; the reference.
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
(($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
(check-var kt k-env)
(for-each (cut check-var <> v-env) arg))
(($ $branch kt ($ $values (arg ...)))
(check-var kt k-env)
(for-each (cut check-var <> v-env) arg))
(($ $primcall (? symbol? name) (arg ...))
(for-each (cut check-var <> v-env) arg))
(($ $values (arg ...))
(for-each (cut check-var <> v-env) arg))
((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
(assert-unary))
(($ $rec names vars funs)
(unless (= (length names) (length vars) (length funs))
(error "invalid $rec" exp))
(assert-n-ary (length names))
(match cont
(($ $kargs names vars*)
(unless (equal? vars* vars)
(error "bound variable mismatch" vars vars*)))))
(($ $values args)
(match cont
(($ $ktail) #t)
(_ (assert-n-ary (length args)))))
(($ $call proc args)
(assert-kreceive-or-ktail))
(($ $callk k proc args)
(assert-kreceive-or-ktail))
(($ $branch kt exp)
(assert-nullary)
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))
(($ $primcall name args)
(match cont
(($ $kargs names)
(match (prim-arity name)
((out . in)
(unless (= in (length args))
(error "bad arity to primcall" name args in))
(unless (= out (length names))
(error "bad return arity from primcall" name names out)))))
(($ $kreceive)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $kreceive" name)))
(($ $ktail)
(error "primitive should continue to $kargs, not $ktail" name))))
(($ $prompt escape? tag handler)
(unless (boolean? escape?) (error "escape? should be boolean" escape?))
(check-var tag v-env)
(check-label handler k-env))
(_
(error "unexpected expression" exp))))
(assert-nullary)
(match (intmap-ref conts handler)
(($ $kreceive) #t)
(cont (error "bad handler" cont))))))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)
(when (intset-ref reachable label)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(unless (= (length names) (length vars))
(error "broken $kargs" label names vars))
(check-arity exp (intmap-ref conts k)))
(_ #t))))
conts)))
(define (visit-term term k-env v-env)
(match term
(($ $letk (($ $cont k cont) ...) body)
(let ((k-env (add-labels k k-env)))
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
(define (check-functions-bound-once conts kfun)
(let ((reachable (compute-reachable-labels conts kfun)))
(define (add-fun fun functions)
(when (intset-ref functions fun)
(error "function already bound" fun))
(intset-add functions fun))
(intmap-fold
(lambda (label cont functions)
(if (intset-ref reachable label)
(match cont
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(add-fun kfun functions))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
(fold1 add-fun kfuns functions))
(_ functions))
functions))
conts
empty-intset)))
(($ $continue k src exp)
(check-label k k-env)
(check-src src)
(visit-expression exp k-env v-env))
(_
(error "unexpected term" term))))
(visit-entry fun '() '())
fun)
(define (verify conts)
(check-distinct-vars conts)
(check-label-partition conts 0)
(check-valid-var-uses conts 0)
(check-arities conts 0)
(check-functions-bound-once conts 0)
conts)

6
module/language/cps2/with-cps.scm → module/language/cps/with-cps.scm
View file

@ -98,9 +98,9 @@
;;;
;;; Code:
(define-module (language cps2 with-cps)
#:use-module (language cps2)
#:use-module (language cps2 utils)
(define-module (language cps with-cps)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps intmap)
#:export (with-cps with-cps-constants))

362
module/language/cps2.scm
View file

@ -1,362 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; [Transitional note: CPS2 is a new version of CPS, and is a bit of an
;;; experiment. All of the comments in this file pretend that CPS2 will
;;; replace CPS, and will be named CPS.]
;;;
;;; This is the continuation-passing style (CPS) intermediate language
;;; (IL) for Guile.
;;;
;;; In CPS, a term is a labelled expression that calls a continuation.
;;; A function is a collection of terms. No term belongs to more than
;;; one function. The function is identified by the label of its entry
;;; term, and its body is composed of those terms that are reachable
;;; from the entry term. A program is a collection of functions,
;;; identified by the entry label of the entry function.
;;;
;;; Terms are themselves wrapped in continuations, which specify how
;;; predecessors may continue to them. For example, a $kargs
;;; continuation specifies that the term may be called with a specific
;;; number of values, and that those values will then be bound to
;;; lexical variables. $kreceive specifies that some number of values
;;; will be passed on the stack, as from a multiple-value return. Those
;;; values will be passed to a $kargs, if the number of values is
;;; compatible with the $kreceive's arity. $kfun is an entry point to a
;;; function, and receives arguments according to a well-known calling
;;; convention (currently, on the stack) and the stack before
;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
;;; only appears within a $kfun; it checks the incoming values for the
;;; correct arity and dispatches to a $kargs, or to the next clause.
;;; Finally, $ktail is the tail continuation for a function, and
;;; contains no term.
;;;
;;; Each continuation has a label that is unique in the program. As an
;;; implementation detail, the labels are integers, which allows us to
;;; easily sort them topologically. A program is a map from integers to
;;; continuations, where continuation 0 in the map is the entry point
;;; for the program, and is a $kfun of no arguments.
;;;
;;; $continue nodes call continuations. The expression contained in the
;;; $continue node determines the value or values that are passed to the
;;; target continuation: $const to pass a constant value, $values to
;;; pass multiple named values, etc. $continue nodes also record the
;;; source location corresponding to the expression.
;;;
;;; As mentioned above, a $kargs continuation can bind variables, if it
;;; receives incoming values. $kfun also binds a value, corresponding
;;; to the closure being called. A traditional CPS implementation will
;;; nest terms in each other, binding them in "let" forms, ensuring that
;;; continuations are declared and bound within the scope of the values
;;; that they may use. In this way, the scope tree is a proof that
;;; variables are defined before they are used. However, this proof is
;;; conservative; it is possible for a variable to always be defined
;;; before it is used, but not to be in scope:
;;;
;;; (letrec ((k1 (lambda (v1) (k2)))
;;; (k2 (lambda () v1)))
;;; (k1 0))
;;;
;;; This example is invalid, as v1 is used outside its scope. However
;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
;;; k1:
;;;
;;; (letrec ((k1 (lambda (v1)
;;; (letrec ((k2 (lambda () v1)))
;;; (k2))))
;;; (k1 0))
;;;
;;; Because program transformation usually uses flow-based analysis,
;;; having to update the scope tree to manifestly prove a transformation
;;; that has already proven correct is needless overhead, and in the
;;; worst case can prevent optimizations from occuring. For that
;;; reason, Guile's CPS language does not nest terms. Instead, we use
;;; the invariant that definitions must dominate uses. To check the
;;; validity of a CPS program is thus more involved than checking for a
;;; well-scoped tree; you have to do flow analysis to determine a
;;; dominator tree. However the flexibility that this grants us is
;;; worth the cost of throwing away the embedded proof of the scope
;;; tree.
;;;
;;; This particular formulation of CPS was inspired by Andrew Kennedy's
;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
;;; hackers should read that excellent paper! As in Kennedy's paper,
;;; continuations are second-class, and may be thought of as basic block
;;; labels. All values are bound to variables using continuation calls:
;;; even constants!
;;;
;;; Finally, note that there are two flavors of CPS: higher-order and
;;; first-order. By "higher-order", we mean that variables may be free
;;; across function boundaries. Higher-order CPS contains $fun and $rec
;;; expressions that declare functions in the scope of their term.
;;; Closure conversion results in first-order CPS, where closure
;;; representations have been explicitly chosen, and all variables used
;;; in a function are bound. Higher-order CPS is good for
;;; interprocedural optimizations like contification and beta reduction,
;;; while first-order CPS is better for instruction selection, register
;;; allocation, and code generation.
;;;
;;; See (language tree-il compile-cps) for details on how Tree-IL
;;; converts to CPS.
;;;
;;; Code:
(define-module (language cps2)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:export (;; Helper.
$arity
make-$arity
;; Continuations.
$kreceive $kargs $kfun $ktail $kclause
;; Terms.
$continue
;; Expressions.
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt
;; Building macros.
build-cont build-term build-exp
rewrite-cont rewrite-term rewrite-exp
;; External representation.
parse-cps unparse-cps))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
(lambda (x)
(define (id-append ctx . syms)
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
(syntax-case x ()
((_ name field ...)
(and (identifier? #'name) (and-map identifier? #'(field ...)))
(with-syntax ((cons (id-append #'name #'make- #'name))
(pred (id-append #'name #'name #'?))
((getter ...) (map (lambda (f)
(id-append f #'name #'- f))
#'(field ...))))
#'(define-record-type name
(cons field ...)
pred
(field getter)
...))))))
(define-syntax-rule (define-cps-type name field ...)
(begin
(define-record-type* name field ...)
(set-record-type-printer! name print-cps)))
(define (print-cps exp port)
(format port "#<cps ~S>" (unparse-cps exp)))
;; Helper.
(define-record-type* $arity req opt rest kw allow-other-keys?)
;; Continuations
(define-cps-type $kreceive arity kbody)
(define-cps-type $kargs names syms term)
(define-cps-type $kfun src meta self ktail kclause)
(define-cps-type $ktail)
(define-cps-type $kclause arity kbody kalternate)
;; Terms.
(define-cps-type $continue k src exp)
;; Expressions.
(define-cps-type $const val)
(define-cps-type $prim name)
(define-cps-type $fun body) ; Higher-order.
(define-cps-type $rec names syms funs) ; Higher-order.
(define-cps-type $closure label nfree) ; First-order.
(define-cps-type $branch kt exp)
(define-cps-type $call proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
(define-syntax build-arity
(syntax-rules (unquote)
((_ (unquote exp)) exp)
((_ (req opt rest kw allow-other-keys?))
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont
(syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kreceive req rest kargs))
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
((_ ($kargs (name ...) (unquote syms) body))
(make-$kargs (list name ...) syms (build-term body)))
((_ ($kargs (name ...) (sym ...) body))
(make-$kargs (list name ...) (list sym ...) (build-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-term body)))
((_ ($kfun src meta self ktail kclause))
(make-$kfun src meta self ktail kclause))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity kbody kalternate))
(make-$kclause (build-arity arity) kbody kalternate))))
(define-syntax build-term
(syntax-rules (unquote $rec $continue)
((_ (unquote exp))
exp)
((_ ($continue k src exp))
(make-$continue k src (build-exp exp)))))
(define-syntax build-exp
(syntax-rules (unquote
$const $prim $fun $rec $closure $branch
$call $callk $primcall $values $prompt)
((_ (unquote exp)) exp)
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($fun kentry)) (make-$fun kentry))
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
((_ ($closure k nfree)) (make-$closure k nfree))
((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
((_ ($callk k proc (unquote args))) (make-$callk k proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args))
((_ ($primcall name (unquote args))) (make-$primcall name args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
((_ ($prompt escape? tag handler))
(make-$prompt escape? tag handler))))
(define-syntax-rule (rewrite-cont x (pat cont) ...)
(match x
(pat (build-cont cont)) ...))
(define-syntax-rule (rewrite-term x (pat term) ...)
(match x
(pat (build-term term)) ...))
(define-syntax-rule (rewrite-exp x (pat body) ...)
(match x
(pat (build-exp body)) ...))
(define (parse-cps exp)
(define (src exp)
(let ((props (source-properties exp)))
(and (pair? props) props)))
(match exp
;; Continuations.
(('kreceive req rest k)
(build-cont ($kreceive req rest k)))
(('kargs names syms body)
(build-cont ($kargs names syms ,(parse-cps body))))
(('kfun src meta self ktail kclause)
(build-cont ($kfun (src exp) meta self ktail kclause)))
(('ktail)
(build-cont ($ktail)))
(('kclause (req opt rest kw allow-other-keys?) kbody)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
(('kclause (req opt rest kw allow-other-keys?) kbody kalt)
(build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
;; Calls.
(('continue k exp)
(build-term ($continue k (src exp) ,(parse-cps exp))))
(('unspecified)
(build-exp ($const *unspecified*)))
(('const exp)
(build-exp ($const exp)))
(('prim name)
(build-exp ($prim name)))
(('fun kbody)
(build-exp ($fun kbody)))
(('closure k nfree)
(build-exp ($closure k nfree)))
(('rec (name sym fun) ...)
(build-exp ($rec name sym (map parse-cps fun))))
(('call proc arg ...)
(build-exp ($call proc arg)))
(('callk k proc arg ...)
(build-exp ($callk k proc arg)))
(('primcall name arg ...)
(build-exp ($primcall name arg)))
(('branch k exp)
(build-exp ($branch k ,(parse-cps exp))))
(('values arg ...)
(build-exp ($values arg)))
(('prompt escape? tag handler)
(build-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
(define (unparse-cps exp)
(match exp
;; Continuations.
(($ $kreceive ($ $arity req () rest () #f) k)
`(kreceive ,req ,rest ,k))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
(($ $kfun src meta self ktail kclause)
`(kfun ,meta ,self ,ktail ,kclause))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
`(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
. ,(if kalternate (list kalternate) '())))
;; Calls.
(($ $continue k src exp)
`(continue ,k ,(unparse-cps exp)))
(($ $const val)
(if (unspecified? val)
'(unspecified)
`(const ,val)))
(($ $prim name)
`(prim ,name))
(($ $fun kbody)
`(fun ,kbody))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $rec names syms funs)
`(rec ,@(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
names syms funs)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
`(callk ,k ,proc ,@args))
(($ $primcall name args)
`(primcall ,name ,@args))
(($ $branch k exp)
`(branch ,k ,(unparse-cps exp)))
(($ $values args)
`(values ,@args))
(($ $prompt escape? tag handler)
`(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))

104
module/language/cps2/compile-cps.scm
View file

@ -1,104 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Compiling CPS2 to CPS. When/if CPS2 replaces CPS, this module will be removed.
;;;
;;; Code:
(define-module (language cps2 compile-cps)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module ((language cps) #:prefix cps:)
#:use-module (language cps2 utils)
#:use-module (language cps2 optimize)
#:use-module (language cps2 renumber)
#:use-module (language cps intmap)
#:export (compile-cps))
;; Precondition: For each function in CONTS, the continuation names are
;; topologically sorted.
(define (conts->fun conts)
(define (convert-fun kfun)
(let ((doms (compute-dom-edges (compute-idoms conts kfun))))
(define (visit-cont label)
(cps:rewrite-cps-cont (intmap-ref conts label)
(($ $kargs names syms body)
(label (cps:$kargs names syms ,(redominate label (visit-term body)))))
(($ $ktail)
(label (cps:$ktail)))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label (cps:$kreceive req rest kargs)))))
(define (visit-clause label)
(and label
(cps:rewrite-cps-cont (intmap-ref conts label)
(($ $kclause ($ $arity req opt rest kw aok?) kbody kalt)
(label (cps:$kclause (req opt rest kw aok?)
,(visit-cont kbody)
,(visit-clause kalt)))))))
(define (redominate label term)
(define (visit-dom-conts label)
(match (intmap-ref conts label)
(($ $ktail) '())
(($ $kargs) (list (visit-cont label)))
(else
(cons (visit-cont label)
(visit-dom-conts* (intmap-ref doms label))))))
(define (visit-dom-conts* labels)
(match labels
(() '())
((label . labels)
(append (visit-dom-conts label)
(visit-dom-conts* labels)))))
(cps:rewrite-cps-term (visit-dom-conts* (intmap-ref doms label))
(() ,term)
(conts (cps:$letk ,conts ,term))))
(define (visit-term term)
(cps:rewrite-cps-term term
(($ $continue k src (and ($ $fun) fun))
(cps:$continue k src ,(visit-fun fun)))
(($ $continue k src ($ $rec names syms funs))
(cps:$continue k src (cps:$rec names syms (map visit-fun funs))))
(($ $continue k src exp)
(cps:$continue k src ,(visit-exp exp)))))
(define (visit-exp exp)
(cps:rewrite-cps-exp exp
(($ $const val) (cps:$const val))
(($ $prim name) (cps:$prim name))
(($ $closure k nfree) (cps:$closure k nfree))
(($ $call proc args) (cps:$call proc args))
(($ $callk k proc args) (cps:$callk k proc args))
(($ $primcall name args) (cps:$primcall name args))
(($ $branch k exp) (cps:$branch k ,(visit-exp exp)))
(($ $values args) (cps:$values args))
(($ $prompt escape? tag handler) (cps:$prompt escape? tag handler))))
(define (visit-fun fun)
(cps:rewrite-cps-exp fun
(($ $fun body)
(cps:$fun ,(convert-fun body)))))
(cps:rewrite-cps-cont (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(kfun (cps:$kfun src meta self (tail (cps:$ktail))
,(visit-clause clause)))))))
(convert-fun 0))
(define (compile-cps exp env opts)
(let ((exp (renumber (optimize exp opts))))
(values (conts->fun exp) env env)))

98
module/language/cps2/constructors.scm
View file

@ -1,98 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Constructor inlining turns "list" primcalls into a series of conses,
;;; and does similar transformations for "vector".
;;;
;;; Code:
(define-module (language cps2 constructors)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 with-cps)
#:use-module (language cps intmap)
#:export (inline-constructors))
(define (inline-list out k src args)
(define (build-list out args k)
(match args
(()
(with-cps out
(build-term ($continue k src ($const '())))))
((arg . args)
(with-cps out
(letv tail)
(letk ktail ($kargs ('tail) (tail)
($continue k src
($primcall 'cons (arg tail)))))
($ (build-list args ktail))))))
(with-cps out
(letv val)
(letk kvalues ($kargs ('val) (val)
($continue k src
($primcall 'values (val)))))
($ (build-list args kvalues))))
(define (inline-vector out k src args)
(define (initialize out vec args n)
(match args
(()
(with-cps out
(build-term ($continue k src ($primcall 'values (vec))))))
((arg . args)
(with-cps out
(let$ next (initialize vec args (1+ n)))
(letk knext ($kargs () () ,next))
($ (with-cps-constants ((idx n))
(build-term ($continue knext src
($primcall 'vector-set! (vec idx arg))))))))))
(with-cps out
(letv vec)
(let$ body (initialize vec args 0))
(letk kalloc ($kargs ('vec) (vec) ,body))
($ (with-cps-constants ((len (length args))
(init #f))
(build-term ($continue kalloc src
($primcall 'make-vector (len init))))))))
(define (find-constructor-inliner name)
(match name
('list inline-list)
('vector inline-vector)
(_ #f)))
(define (inline-constructors conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((inline (find-constructor-inliner name)))
(if inline
(call-with-values (lambda () (inline out k src args))
(lambda (out term)
(intmap-replace! out label
(build-cont ($kargs names vars ,term)))))
out)))
(_ out)))
conts
conts))))

475
module/language/cps2/contification.scm
View file

@ -1,475 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Contification is a pass that turns $fun instances into $cont
;;; instances if all calls to the $fun return to the same continuation.
;;; This is a more rigorous variant of our old "fixpoint labels
;;; allocation" optimization.
;;;
;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
;;; and Weeks's "Contification using Dominators".
;;;
;;; Code:
(define-module (language cps2 contification)
#:use-module (ice-9 match)
#:use-module (srfi srfi-11)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps2)
#:use-module (language cps2 renumber)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (contify))
(define (compute-singly-referenced-labels conts)
"Compute the set of labels in CONTS that have exactly one
predecessor."
(define (add-ref label cont single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match cont
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-functions conts)
"Compute a map from $kfun label to bound variable names for all
functions in CONTS. Functions have two bound variable names: their self
binding, and the name they are given in their continuation. If their
continuation has more than one predecessor, then the bound variable name
doesn't uniquely identify the function, so we exclude that function from
the set."
(define (function-self label)
(match (intmap-ref conts label)
(($ $kfun src meta self) self)))
(let ((single (compute-singly-referenced-labels conts)))
(intmap-fold (lambda (label cont functions)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $fun kfun)))
(if (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs (name) (var))
(intmap-add functions kfun
(intset var (function-self kfun)))))
functions))
(($ $kargs _ _ ($ $continue k src
($ $rec _ vars (($ $fun kfuns) ...))))
(if (intset-ref single k)
(fold (lambda (var kfun functions)
(intmap-add functions kfun
(intset var (function-self kfun))))
functions vars kfuns)
functions))
(_ functions)))
conts
empty-intmap)))
(define (compute-multi-clause conts)
"Compute an set containing all labels that are part of a multi-clause
case-lambda. See the note in compute-contification-candidates."
(define (multi-clause? clause)
(and clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
alt))))
(intmap-fold (lambda (label cont multi)
(match cont
(($ $kfun src meta self tail clause)
(if (multi-clause? clause)
(intset-union multi (compute-function-body conts label))
multi))
(_ multi)))
conts
empty-intset))
(define (compute-arities conts functions)
"Given the map FUNCTIONS whose keys are $kfun labels, return a map
from label to arities."
(define (clause-arities clause)
(if clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(cons arity (clause-arities alt))))
'()))
(intmap-map (lambda (label vars)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(clause-arities clause))))
functions))
;; For now, we don't contify functions with optional, keyword, or rest
;; arguments.
(define (contifiable-arity? arity)
(match arity
(($ $arity req () #f () aok?)
#t)
(_
#f)))
(define (arity-matches? arity nargs)
(match arity
(($ $arity req () #f () aok?)
(= nargs (length req)))
(_
#f)))
(define (compute-contification-candidates conts)
"Compute and return a label -> (variable ...) map describing all
functions with known uses that are only ever used as the operator of a
$call, and are always called with a compatible arity."
(let* ((functions (compute-functions conts))
(multi-clause (compute-multi-clause conts))
(vars (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
functions
empty-intmap))
(arities (compute-arities conts functions)))
(define (restrict-arity functions proc nargs)
(match (intmap-ref vars proc (lambda (_) #f))
(#f functions)
(label
(let lp ((arities (intmap-ref arities label)))
(match arities
(() (intmap-remove functions label))
((arity . arities)
(cond
((not (contifiable-arity? arity)) (lp '()))
((arity-matches? arity nargs) functions)
(else (lp arities)))))))))
(define (visit-cont label cont functions)
(define (exclude-var functions var)
(match (intmap-ref vars var (lambda (_) #f))
(#f functions)
(label (intmap-remove functions label))))
(define (exclude-vars functions vars)
(match vars
(() functions)
((var . vars)
(exclude-vars (exclude-var functions var) vars))))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec))
functions)
(($ $values args)
(exclude-vars functions args))
(($ $call proc args)
(let ((functions (exclude-vars functions args)))
;; This contification algorithm is happy to contify the
;; `lp' in this example into a shared tail between clauses:
;;
;; (letrec ((lp (lambda () (lp))))
;; (case-lambda
;; ((a) (lp))
;; ((a b) (lp))))
;;
;; However because the current compilation pipeline has to
;; re-nest continuations into old CPS, there would be no
;; scope in which the tail would be valid. So, until the
;; old compilation pipeline is completely replaced,
;; conservatively exclude contifiable fucntions called
;; from multi-clause procedures.
(if (intset-ref multi-clause label)
(exclude-var functions proc)
(restrict-arity functions proc (length args)))))
(($ $callk k proc args)
(exclude-vars functions (cons proc args)))
(($ $branch kt ($ $primcall name args))
(exclude-vars functions args))
(($ $branch kt ($ $values (arg)))
(exclude-var functions arg))
(($ $primcall name args)
(exclude-vars functions args))
(($ $prompt escape? tag handler)
(exclude-var functions tag))))
(_ functions)))
(intmap-fold visit-cont conts functions)))
(define (compute-call-graph conts labels vars)
"Given the set of contifiable functions LABELS and associated bound
variables VARS, compute and return two values: a map
LABEL->LABEL... indicating the contifiable functions called by a
function, and a map LABEL->LABEL... indicating the return continuations
for a function. The first return value also has an entry
0->LABEL... indicating all contifiable functions called by
non-contifiable functions. We assume that 0 is not in the contifiable
function set."
(let ((bodies
;; label -> fun-label for all labels in bodies of contifiable
;; functions
(intset-fold (lambda (fun-label bodies)
(intset-fold (lambda (label bodies)
(intmap-add bodies label fun-label))
(compute-function-body conts fun-label)
bodies))
labels
empty-intmap)))
(when (intset-ref labels 0)
(error "internal error: label 0 should not be contifiable"))
(intmap-fold
(lambda (label cont calls returns)
(match cont
(($ $kargs _ _ ($ $continue k src ($ $call proc)))
(match (intmap-ref vars proc (lambda (_) #f))
(#f (values calls returns))
(callee
(let ((caller (intmap-ref bodies label (lambda (_) 0))))
(values (intmap-add calls caller callee intset-add)
(intmap-add returns callee k intset-add))))))
(_ (values calls returns))))
conts
(intset->intmap (lambda (label) empty-intset) (intset-add labels 0))
(intset->intmap (lambda (label) empty-intset) labels))))
(define (tail-label conts label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail body)
tail)))
(define (compute-return-labels labels tails returns return-substs)
(define (subst k)
(match (intmap-ref return-substs k (lambda (_) #f))
(#f k)
(k (subst k))))
;; Compute all return labels, then subtract tail labels of the
;; functions in question.
(intset-subtract
;; Return labels for all calls to these labels.
(intset-fold (lambda (label out)
(intset-fold (lambda (k out)
(intset-add out (subst k)))
(intmap-ref returns label)
out))
labels
empty-intset)
(intset-fold (lambda (label out)
(intset-add out (intmap-ref tails label)))
labels
empty-intset)))
(define (intmap->intset map)
(define (add-key label cont labels)
(intset-add labels label))
(intmap-fold add-key map empty-intset))
(define (filter-contifiable contified groups)
(intmap-fold (lambda (id labels groups)
(let ((labels (intset-subtract labels contified)))
(if (eq? empty-intset labels)
groups
(intmap-add groups id labels))))
groups
empty-intmap))
(define (trivial-set set)
(let ((first (intset-next set)))
(and first
(not (intset-next set (1+ first)))
first)))
(define (compute-contification conts)
(let*-values
(;; label -> (var ...)
((candidates) (compute-contification-candidates conts))
((labels) (intmap->intset candidates))
;; var -> label
((vars) (intmap-fold (lambda (label vars out)
(intset-fold (lambda (var out)
(intmap-add out var label))
vars out))
candidates
empty-intmap))
;; caller-label -> callee-label..., callee-label -> return-label...
((calls returns) (compute-call-graph conts labels vars))
;; callee-label -> tail-label
((tails) (intset-fold
(lambda (label tails)
(intmap-add tails label (tail-label conts label)))
labels
empty-intmap))
;; Strongly connected components, allowing us to contify mutually
;; tail-recursive functions. Since `compute-call-graph' added on
;; a synthetic 0->LABEL... entry for contifiable functions called
;; by non-contifiable functions, we need to remove that entry
;; from the partition. It will be in its own component, as it
;; has no predecessors.
;;
;; id -> label...
((groups) (intmap-remove
(compute-strongly-connected-components calls 0)
0)))
;; todo: thread groups through contification
(define (attempt-contification labels contified return-substs)
(let ((returns (compute-return-labels labels tails returns
return-substs)))
(cond
((trivial-set returns)
=> (lambda (k)
;; Success!
(values (intset-union contified labels)
(intset-fold (lambda (label return-substs)
(let ((tail (intmap-ref tails label)))
(intmap-add return-substs tail k)))
labels return-substs))))
((trivial-set labels)
;; Single-label SCC failed to contify.
(values contified return-substs))
(else
;; Multi-label SCC failed to contify. Try instead to contify
;; each one.
(intset-fold
(lambda (label contified return-substs)
(let ((labels (intset-add empty-intset label)))
(attempt-contification labels contified return-substs)))
labels contified return-substs)))))
(call-with-values
(lambda ()
(fixpoint
(lambda (contified return-substs)
(intmap-fold
(lambda (id group contified return-substs)
(attempt-contification group contified return-substs))
(filter-contifiable contified groups)
contified
return-substs))
empty-intset
empty-intmap))
(lambda (contified return-substs)
(values (intset-fold (lambda (label call-substs)
(intset-fold
(lambda (var call-substs)
(intmap-add call-substs var label))
(intmap-ref candidates label)
call-substs))
contified
empty-intmap)
return-substs)))))
(define (apply-contification conts call-substs return-substs)
(define (call-subst proc)
(intmap-ref call-substs proc (lambda (_) #f)))
(define (return-subst k)
(intmap-ref return-substs k (lambda (_) #f)))
(define (find-body kfun nargs)
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(let lp ((clause clause))
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(if (arity-matches? arity nargs)
body
(lp alt))))))))
(define (continue k src exp)
(define (lookup-return-cont k)
(match (return-subst k)
(#f k)
(k (lookup-return-cont k))))
(let ((k* (lookup-return-cont k)))
(if (eq? k k*)
(build-term ($continue k src ,exp))
;; We are contifying this return. It must be a call, a
;; $values expression, or a return primcall. k* will be
;; either a $ktail or a $kreceive continuation. CPS2 has this
;; thing though where $kreceive can't be the target of a
;; $values expression, and "return" can only continue to a
;; tail continuation, so we might have to rewrite to a
;; "values" primcall.
(build-term
($continue k* src
,(match (intmap-ref conts k*)
(($ $kreceive)
(match exp
(($ $primcall 'return (val))
(build-exp ($primcall 'values (val))))
(($ $call) exp)
;; Except for 'return, a primcall that can continue
;; to $ktail can also continue to $kreceive. TODO:
;; replace 'return with 'values, for consistency.
(($ $primcall) exp)
(($ $values vals)
(build-exp ($primcall 'values vals)))))
(($ $ktail) exp)))))))
(define (visit-exp k src exp)
(match exp
(($ $call proc args)
;; If proc is contifiable, replace call with jump.
(match (call-subst proc)
(#f (continue k src exp))
(kfun
(let ((body (find-body kfun (length args))))
(build-term ($continue body src ($values args)))))))
(($ $fun kfun)
;; If the function's tail continuation has been
;; substituted, that means it has been contified.
(if (return-subst (tail-label conts kfun))
(continue k src (build-exp ($values ())))
(continue k src exp)))
(($ $rec names vars funs)
(match (filter (match-lambda ((n v f) (not (call-subst v))))
(map list names vars funs))
(() (continue k src (build-exp ($values ()))))
(((names vars funs) ...)
(continue k src (build-exp ($rec names vars funs))))))
(_ (continue k src exp))))
;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been
;; wired into other functions.
(renumber
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
;; Remove bindings for functions that have been contified.
(match (filter (match-lambda ((name var) (not (call-subst var))))
(map list names vars))
(((names vars) ...)
(build-cont
($kargs names vars ,(visit-exp k src exp))))))
(_ cont)))
conts)))
(define (contify conts)
;; FIXME: Renumbering isn't really needed but dead continuations may
;; cause compute-singly-referenced-labels to spuriously mark some
;; conts as irreducible. For now we punt and renumber so that there
;; are only live conts.
(let ((conts (renumber conts)))
(let-values (((call-substs return-substs) (compute-contification conts)))
(apply-contification conts call-substs return-substs))))

449
module/language/cps2/cse.scm
View file

@ -1,449 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Common subexpression elimination for CPS.
;;;
;;; Code:
(define-module (language cps2 cse)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 effects-analysis)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-common-subexpressions))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define (compute-available-expressions conts kfun effects)
"Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is
an intset containing ancestor labels whose value is available at LABEL."
(define (propagate avail succ out)
(let* ((in (intmap-ref avail succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() avail)
(values (list succ)
(intmap-add avail succ in* (lambda (old new) new))))))
(define (clobber label in)
(let ((fx (intmap-ref effects label)))
(cond
((not (causes-effect? fx &write))
;; Fast-path if this expression clobbers nothing.
in)
(else
;; Kill clobbered expressions. FIXME: there is no need to check
;; on any label before than the last dominating label that
;; clobbered everything. Another way to speed things up would
;; be to compute a clobber set per-effect, which we could
;; subtract from "in".
(let lp ((label 0) (in in))
(cond
((intset-next in label)
=> (lambda (label)
(if (effect-clobbers? fx (intmap-ref effects label))
(lp (1+ label) (intset-remove in label))
(lp (1+ label) in))))
(else in)))))))
(define (visit-cont label avail)
(let* ((in (intmap-ref avail label))
(out (intset-add (clobber label in) label)))
(define (propagate0)
(values '() avail))
(define (propagate1 succ)
(propagate avail succ out))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 avail) (propagate avail succ0 out))
((changed1 avail) (propagate avail succ1 out)))
(values (append changed0 changed1) avail)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate2 k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (compute-truthy-expressions conts kfun boolv)
"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..
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)))
(if (eq? in in*)
(values '() boolv)
(values (list succ)
(intmap-add boolv succ in* (lambda (old new) new))))))
(define (visit-cont label boolv)
(let ((in (intmap-ref boolv label)))
(define (propagate0)
(values '() boolv))
(define (propagate1 succ)
(propagate boolv succ in))
(define (propagate2 succ0 succ1)
(let*-values (((changed0 boolv) (propagate boolv succ0 in))
((changed1 boolv) (propagate boolv succ1 in)))
(values (append changed0 changed1) boolv)))
(define (propagate-branch succ0 succ1)
(let*-values (((changed0 boolv)
(propagate boolv succ0
(intset-add in (false-idx label))))
((changed1 boolv)
(propagate boolv succ1
(intset-add in (true-idx label)))))
(values (append changed0 changed1) boolv)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $branch kt) (propagate-branch k kt))
(($ $prompt escape? tag handler) (propagate2 k handler))
(_ (propagate1 k))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
(if clause
(propagate1 clause)
(propagate0)))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt)
(propagate1 kbody)))
(($ $ktail) (propagate0)))))
(let ((boolv (worklist-fold* visit-cont
(intset kfun)
(intmap-add boolv kfun empty-intset))))
;; Now visit nested functions. We don't do this in the worklist
;; folder because that would be exponential.
(define (recurse kfun boolv)
(compute-truthy-expressions conts kfun boolv))
(intset-fold
(lambda (label boolv)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
(($ $fun kfun) (recurse kfun boolv))
(($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun))
(_ boolv)))
(_ boolv)))
(compute-function-body conts kfun)
boolv)))
(define (intset-map f set)
(persistent-intmap
(intset-fold (lambda (i out) (intmap-add! out i (f i)))
set
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)
(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 ($ $continue k))
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))))
(compute-function-body conts kfun)))
(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)))))
(define (compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs)
(let* ((succs (compute-successors conts kfun))
(singly-referenced (compute-singly-referenced succs))
(avail (compute-available-expressions conts 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-exp-key var-substs exp)
(match exp
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
(($ $fun body) #f)
(($ $rec names syms funs) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args))
(cons* 'primcall name (subst-vars var-substs args)))
(($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
(define (add-auxiliary-definitions! label var-substs exp-key)
(define (subst var)
(subst-var var-substs var))
(let ((defs (intmap-ref defs label)))
(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))))
(match exp-key
(('primcall 'box val)
(match defs
((box)
(add-def! `(primcall box-ref ,(subst box)) val))))
(('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val))
(('primcall 'cons car cdr)
(match defs
((pair)
(add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr))))
(('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car))
(('primcall 'set-cdr! pair cdr)
(add-def! `(primcall cdr ,pair) cdr))
(('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs
((vec)
(add-def! `(primcall vector-length ,(subst vec)) len))))
(('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val))
(('primcall 'vector-set!/immediate vec idx val)
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
(('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size)
(match defs
((struct)
(add-def! `(primcall struct-vtable ,(subst struct))
vtable))))
(('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val))
(('primcall 'struct-set!/immediate struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
(_ #t))))
(define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let* ((exp-key (compute-exp-key var-substs exp))
(equiv (hash-ref equiv-set exp-key '()))
(fx (intmap-ref effects label))
(avail (intmap-ref avail label)))
(define (finish equiv-labels var-substs)
(define (recurse kfun equiv-labels var-substs)
(compute-equivalent-subexpressions conts kfun effects
equiv-labels var-substs))
;; 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 var-substs exp-key)
(match exp
;; If we see a $fun, recurse to add to the result.
(($ $fun kfun)
(recurse kfun equiv-labels var-substs))
(($ $rec names vars (($ $fun kfun) ...))
(fold2 recurse kfun equiv-labels var-substs))
(_
(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).
(when (and exp-key
(not (causes-effect? fx &allocation))
(not (effect-clobbers? fx (&read-object &fluid))))
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(when defs
(hash-set! equiv-set exp-key
(acons label defs equiv)))))
(finish equiv-labels var-substs))
(((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.
(finish (intmap-add equiv-labels label head)
(let ((defs (and (intset-ref singly-referenced k)
(intmap-ref defs label))))
(if defs
(fold (lambda (def var var-substs)
(intmap-add var-substs def var))
var-substs defs vars)
var-substs))))))))))
(_ (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)))
(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)) ,exp)
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
($callk k (subst-var proc) ,(map subst-var args)))
(($ $primcall name args)
($primcall name ,(map subst-var args)))
(($ $branch k exp)
($branch k ,(visit-exp exp)))
(($ $values args)
($values ,(map subst-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst-var tag) handler))))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(build-cont
($kargs names vars
,(match (intmap-ref equiv-labels label (lambda (_) #f))
((equiv . vars)
(match exp
(($ $branch kt exp)
(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
($continue k src
($branch kt ,(visit-exp exp))))
(build-term
($continue (if t kt k) src ($values ()))))))
(_
;; For better or for worse, we only replace primcalls
;; if they have an associated VM op, which allows
;; them to continue to $kargs and thus we know their
;; defs and can use a $values expression instead of a
;; values primcall.
(build-term
($continue k src ($values vars))))))
(#f
(build-term
($continue k src ,(visit-exp exp))))))))
(_ cont)))
conts))
(define (eliminate-common-subexpressions conts)
(call-with-values
(lambda ()
(let ((effects (synthesize-definition-effects (compute-effects conts))))
(compute-equivalent-subexpressions conts 0 effects
empty-intmap empty-intmap)))
(lambda (equiv-labels var-substs)
(let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap)))
(apply-cse conts equiv-labels var-substs truthy-labels)))))

378
module/language/cps2/dce.scm
View file

@ -1,378 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; This pass kills dead expressions: code that has no side effects, and
;;; whose value is unused. It does so by marking all live values, and
;;; then discarding other values as dead. This happens recursively
;;; through procedures, so it should be possible to elide dead
;;; procedures as well.
;;;
;;; Code:
(define-module (language cps2 dce)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps2)
#:use-module (language cps2 effects-analysis)
#:use-module (language cps2 renumber)
#:use-module (language cps2 types)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (eliminate-dead-code))
(define (elide-type-checks conts kfun effects)
"Elide &type-check effects from EFFECTS for the function starting at
KFUN where we can prove that no assertion will be raised at run-time."
(let ((types (infer-types conts kfun)))
(define (visit-primcall effects fx label name args)
(if (primcall-types-check? types label name args)
(intmap-replace! effects label (logand fx (lognot &type-check)))
effects))
(persistent-intmap
(intmap-fold (lambda (label types effects)
(let ((fx (intmap-ref effects label)))
(cond
((causes-all-effects? fx) effects)
((causes-effect? fx &type-check)
(match (intmap-ref conts label)
(($ $kargs _ _ exp)
(match exp
(($ $continue k src ($ $primcall name args))
(visit-primcall effects fx label name args))
(($ $continue k src
($ $branch _ ($primcall name args)))
(visit-primcall effects fx label name args))
(_ effects)))
(_ effects)))
(else effects))))
types
effects))))
(define (compute-effects/elide-type-checks conts)
(intmap-fold (lambda (label cont effects)
(match cont
(($ $kfun) (elide-type-checks conts label effects))
(_ effects)))
conts
(compute-effects conts)))
(define (fold-local-conts proc conts label seed)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let lp ((label label) (seed seed))
(if (<= label tail)
(lp (1+ label) (proc label (intmap-ref conts label) seed))
seed)))))
(define (postorder-fold-local-conts2 proc conts label seed0 seed1)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(let ((start label))
(let lp ((label tail) (seed0 seed0) (seed1 seed1))
(if (<= start label)
(let ((cont (intmap-ref conts label)))
(call-with-values (lambda () (proc label cont seed0 seed1))
(lambda (seed0 seed1)
(lp (1- label) seed0 seed1))))
(values seed0 seed1)))))))
(define (compute-known-allocations conts effects)
"Compute the variables bound in CONTS that have known allocation
sites."
;; Compute the set of conts that are called with freshly allocated
;; values, and subtract from that set the conts that might be called
;; with values with unknown allocation sites. Then convert that set
;; of conts into a set of bound variables.
(call-with-values
(lambda ()
(intmap-fold (lambda (label cont known unknown)
;; Note that we only need to add labels to the
;; known/unknown sets if the labels can bind
;; values. So there's no need to add tail,
;; clause, branch alternate, or prompt handler
;; labels, as they bind no values.
(match cont
(($ $kargs _ _ ($ $continue k))
(let ((fx (intmap-ref effects label)))
(if (and (not (causes-all-effects? fx))
(causes-effect? fx &allocation))
(values (intset-add! known k) unknown)
(values known (intset-add! unknown k)))))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
(values known unknown))
(($ $kclause arity body alt)
(values known (intset-add! unknown body)))
(($ $ktail)
(values known unknown))))
conts
empty-intset
empty-intset))
(lambda (known unknown)
(persistent-intset
(intset-fold (lambda (label vars)
(match (intmap-ref conts label)
(($ $kargs (_) (var)) (intset-add! vars var))
(_ vars)))
(intset-subtract (persistent-intset known)
(persistent-intset unknown))
empty-intset)))))
(define (compute-live-code conts)
(let* ((effects (compute-effects/elide-type-checks conts))
(known-allocations (compute-known-allocations conts effects)))
(define (adjoin-var var set)
(intset-add set var))
(define (adjoin-vars vars set)
(match vars
(() set)
((var . vars) (adjoin-vars vars (adjoin-var var set)))))
(define (var-live? var live-vars)
(intset-ref live-vars var))
(define (any-var-live? vars live-vars)
(match vars
(() #f)
((var . vars)
(or (var-live? var live-vars)
(any-var-live? vars live-vars)))))
(define (cont-defs k)
(match (intmap-ref conts k)
(($ $kargs _ vars) vars)
(_ #f)))
(define (visit-live-exp label k exp live-exps live-vars)
(match exp
((or ($ $const) ($ $prim))
(values live-exps live-vars))
(($ $fun body)
(visit-fun body live-exps live-vars))
(($ $rec names vars (($ $fun kfuns) ...))
(let lp ((vars vars) (kfuns kfuns)
(live-exps live-exps) (live-vars live-vars))
(match (vector vars kfuns)
(#(() ()) (values live-exps live-vars))
(#((var . vars) (kfun . kfuns))
(if (var-live? var live-vars)
(call-with-values (lambda ()
(visit-fun kfun live-exps live-vars))
(lambda (live-exps live-vars)
(lp vars kfuns live-exps live-vars)))
(lp vars kfuns live-exps live-vars))))))
(($ $prompt escape? tag handler)
(values live-exps (adjoin-var tag live-vars)))
(($ $call proc args)
(values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk k proc args)
(values live-exps (adjoin-vars args (adjoin-var proc live-vars))))
(($ $primcall name args)
(values live-exps (adjoin-vars args live-vars)))
(($ $branch k ($ $primcall name args))
(values live-exps (adjoin-vars args live-vars)))
(($ $branch k ($ $values (arg)))
(values live-exps (adjoin-var arg live-vars)))
(($ $values args)
(values live-exps
(match (cont-defs k)
(#f (adjoin-vars args live-vars))
(defs (fold (lambda (use def live-vars)
(if (var-live? def live-vars)
(adjoin-var use live-vars)
live-vars))
live-vars args defs)))))))
(define (visit-exp label k exp live-exps live-vars)
(cond
((intset-ref live-exps label)
;; Expression live already.
(visit-live-exp label k exp live-exps live-vars))
((let ((defs (cont-defs k))
(fx (intmap-ref effects label)))
(or
;; No defs; perhaps continuation is $ktail.
(not defs)
;; We don't remove branches.
(match exp (($ $branch) #t) (_ #f))
;; Do we have a live def?
(any-var-live? defs live-vars)
;; Does this expression cause all effects? If so, it's
;; definitely live.
(causes-all-effects? fx)
;; Does it cause a type check, but we weren't able to prove
;; that the types check?
(causes-effect? fx &type-check)
;; We might have a setter. If the object being assigned to
;; is live or was not created by us, then this expression is
;; live. Otherwise the value is still dead.
(and (causes-effect? fx &write)
(match exp
(($ $primcall
(or 'vector-set! 'vector-set!/immediate
'set-car! 'set-cdr!
'box-set!)
(obj . _))
(or (var-live? obj live-vars)
(not (intset-ref known-allocations obj))))
(_ #t)))))
;; Mark expression as live and visit.
(visit-live-exp label k exp (intset-add live-exps label) live-vars))
(else
;; Still dead.
(values live-exps live-vars))))
(define (visit-fun label live-exps live-vars)
;; Visit uses before definitions.
(postorder-fold-local-conts2
(lambda (label cont live-exps live-vars)
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(visit-exp label k exp live-exps live-vars))
(($ $kreceive arity kargs)
(values live-exps live-vars))
(($ $kclause arity kargs kalt)
(values live-exps (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
(values live-exps (adjoin-var self live-vars)))
(($ $ktail)
(values live-exps live-vars))))
conts label live-exps live-vars))
(fixpoint (lambda (live-exps live-vars)
(visit-fun 0 live-exps live-vars))
empty-intset
empty-intset)))
(define-syntax adjoin-conts
(syntax-rules ()
((_ (exp ...) clause ...)
(let ((cps (exp ...)))
(adjoin-conts cps clause ...)))
((_ cps (label cont) clause ...)
(adjoin-conts (intmap-add! cps label (build-cont cont))
clause ...))
((_ cps)
cps)))
(define (process-eliminations conts live-exps live-vars)
(define (exp-live? label)
(intset-ref live-exps label))
(define (value-live? var)
(intset-ref live-vars var))
(define (make-adaptor k src defs)
(let* ((names (map (lambda (_) 'tmp) defs))
(vars (map (lambda (_) (fresh-var)) defs))
(live (filter-map (lambda (def var)
(and (value-live? def) var))
defs vars)))
(build-cont
($kargs names vars
($continue k src ($values live))))))
(define (visit-term label term cps)
(match term
(($ $continue k src exp)
(if (exp-live? label)
(match exp
(($ $fun body)
(values (visit-fun body cps)
term))
(($ $rec names vars funs)
(match (filter-map (lambda (name var fun)
(and (value-live? var)
(list name var fun)))
names vars funs)
(()
(values cps
(build-term ($continue k src ($values ())))))
(((names vars funs) ...)
(values (fold1 (lambda (fun cps)
(match fun
(($ $fun kfun)
(visit-fun kfun cps))))
funs cps)
(build-term ($continue k src
($rec names vars funs)))))))
(_
(match (intmap-ref conts k)
(($ $kargs ())
(values cps term))
(($ $kargs names ((? value-live?) ...))
(values cps term))
(($ $kargs names vars)
(match exp
(($ $values args)
(let ((args (filter-map (lambda (use def)
(and (value-live? def) use))
args vars)))
(values cps
(build-term
($continue k src ($values args))))))
(_
(let-fresh (adapt) ()
(values (adjoin-conts cps
(adapt ,(make-adaptor k src vars)))
(build-term
($continue adapt src ,exp)))))))
(_
(values cps term)))))
(values cps
(build-term
($continue k src ($values ()))))))))
(define (visit-cont label cont cps)
(match cont
(($ $kargs names vars term)
(match (filter-map (lambda (name var)
(and (value-live? var)
(cons name var)))
names vars)
(((names . vars) ...)
(call-with-values (lambda () (visit-term label term cps))
(lambda (cps term)
(adjoin-conts cps
(label ($kargs names vars ,term))))))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(let ((defs (match (intmap-ref conts kargs)
(($ $kargs names vars) vars))))
(if (and-map value-live? defs)
(adjoin-conts cps (label ,cont))
(let-fresh (adapt) ()
(adjoin-conts cps
(adapt ,(make-adaptor kargs #f defs))
(label ($kreceive req rest adapt)))))))
(_
(adjoin-conts cps (label ,cont)))))
(define (visit-fun kfun cps)
(fold-local-conts visit-cont conts kfun cps))
(with-fresh-name-state conts
(persistent-intmap (visit-fun 0 empty-intmap))))
(define (eliminate-dead-code conts)
;; We work on a renumbered program so that we can easily visit uses
;; before definitions just by visiting higher-numbered labels before
;; lower-numbered labels. Renumbering is also a precondition for type
;; inference.
(let ((conts (renumber conts)))
(call-with-values (lambda () (compute-live-code conts))
(lambda (live-exps live-vars)
(process-eliminations conts live-exps live-vars)))))
;;; Local Variables:
;;; eval: (put 'adjoin-conts 'scheme-indent-function 1)
;;; End:

484
module/language/cps2/effects-analysis.scm
View file

@ -1,484 +0,0 @@
;;; Effects analysis on CPS
;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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:
;;;
;;; A helper module to compute the set of effects caused by an
;;; expression. This information is useful when writing algorithms that
;;; move code around, while preserving the semantics of an input
;;; program.
;;;
;;; The effects set is represented as an integer with three parts. The
;;; low 4 bits indicate effects caused by an expression, as a bitfield.
;;; The next 4 bits indicate the kind of memory accessed by the
;;; expression, if it accesses mutable memory. Finally the rest of the
;;; bits indicate the field in the object being accessed, if known, or
;;; -1 for unknown.
;;;
;;; In this way we embed a coarse type-based alias analysis in the
;;; effects analysis. For example, a "car" call is modelled as causing
;;; a read to field 0 on a &pair, and causing a &type-check effect. If
;;; any intervening code sets the car of any pair, that will block
;;; motion of the "car" call, because any write to field 0 of a pair is
;;; seen by effects analysis as being a write to field 0 of all pairs.
;;;
;;; Code:
(define-module (language cps2 effects-analysis)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (ice-9 match)
#:export (expression-effects
compute-effects
synthesize-definition-effects
&allocation
&type-check
&read
&write
&fluid
&prompt
&car
&cdr
&vector
&box
&module
&struct
&string
&bytevector
&object
&field
&allocate
&read-object
&read-field
&write-object
&write-field
&no-effects
&all-effects
exclude-effects
effect-free?
constant?
causes-effect?
causes-all-effects?
effect-clobbers?))
(define-syntax define-flags
(lambda (x)
(syntax-case x ()
((_ all shift name ...)
(let ((count (length #'(name ...))))
(with-syntax (((n ...) (iota count))
(count count))
#'(begin
(define-syntax name (identifier-syntax (ash 1 n)))
...
(define-syntax all (identifier-syntax (1- (ash 1 count))))
(define-syntax shift (identifier-syntax count)))))))))
(define-syntax define-enumeration
(lambda (x)
(define (count-bits n)
(let lp ((out 1))
(if (< n (ash 1 (1- out)))
out
(lp (1+ out)))))
(syntax-case x ()
((_ mask shift name ...)
(let* ((len (length #'(name ...)))
(bits (count-bits len)))
(with-syntax (((n ...) (iota len))
(bits bits))
#'(begin
(define-syntax name (identifier-syntax n))
...
(define-syntax mask (identifier-syntax (1- (ash 1 bits))))
(define-syntax shift (identifier-syntax bits)))))))))
(define-flags &all-effect-kinds &effect-kind-bits
;; Indicates that an expression may cause a type check. A type check,
;; for the purposes of this analysis, is the possibility of throwing
;; an exception the first time an expression is evaluated. If the
;; expression did not cause an exception to be thrown, users can
;; assume that evaluating the expression again will not cause an
;; exception to be thrown.
;;
;; For example, (+ x y) might throw if X or Y are not numbers. But if
;; it doesn't throw, it should be safe to elide a dominated, common
;; subexpression (+ x y).
&type-check
;; Indicates that an expression may return a fresh object. The kind
;; of object is indicated in the object kind field.
&allocation
;; Indicates that an expression may cause a read from memory. The
;; kind of memory is given in the object kind field. Some object
;; kinds have finer-grained fields; those are expressed in the "field"
;; part of the effects value. -1 indicates "the whole object".
&read
;; Indicates that an expression may cause a write to memory.
&write)
(define-enumeration &memory-kind-mask &memory-kind-bits
;; Indicates than an expression may access unknown kinds of memory.
&unknown-memory-kinds
;; Indicates that an expression depends on the value of a fluid
;; variable, or on the current fluid environment.
&fluid
;; Indicates that an expression depends on the current prompt
;; stack.
&prompt
;; Indicates that an expression depends on the value of the car or cdr
;; of a pair.
&pair
;; Indicates that an expression depends on the value of a vector
;; field. The effect field indicates the specific field, or zero for
;; an unknown field.
&vector
;; Indicates that an expression depends on the value of a variable
;; cell.
&box
;; Indicates that an expression depends on the current module.
&module
;; Indicates that an expression depends on the value of a struct
;; field. The effect field indicates the specific field, or zero for
;; an unknown field.
&struct
;; Indicates that an expression depends on the contents of a string.
&string
;; Indicates that an expression depends on the contents of a
;; bytevector. We cannot be more precise, as bytevectors may alias
;; other bytevectors.
&bytevector)
(define-inlinable (&field kind field)
(ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
(define-inlinable (&object kind)
(&field kind -1))
(define-inlinable (&allocate kind)
(logior &allocation (&object kind)))
(define-inlinable (&read-field kind field)
(logior &read (&field kind field)))
(define-inlinable (&read-object kind)
(logior &read (&object kind)))
(define-inlinable (&write-field kind field)
(logior &write (&field kind field)))
(define-inlinable (&write-object kind)
(logior &write (&object kind)))
(define-syntax &no-effects (identifier-syntax 0))
(define-syntax &all-effects
(identifier-syntax
(logior &all-effect-kinds (&object &unknown-memory-kinds))))
(define-inlinable (constant? effects)
(zero? effects))
(define-inlinable (causes-effect? x effects)
(not (zero? (logand x effects))))
(define-inlinable (causes-all-effects? x)
(eqv? x &all-effects))
(define (effect-clobbers? a b)
"Return true if A clobbers B. This is the case if A is a write, and B
is or might be a read or a write to the same location as A."
(define (locations-same?)
(let ((a (ash a (- &effect-kind-bits)))
(b (ash b (- &effect-kind-bits))))
(or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
(eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
(and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
;; 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))))
(locations-same?)))
(define-inlinable (indexed-field kind var constants)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(if (and (exact-integer? val) (<= 0 val))
(&field kind val)
(&object kind))))
(define *primitive-effects* (make-hash-table))
(define-syntax-rule (define-primitive-effects* constants
((name . args) effects ...)
...)
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda*
((constants . args) (logior effects ...))
(_ &all-effects)))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
(define-primitive-effects* constants ((name . args) effects ...) ...))
;; Miscellaneous.
(define-primitive-effects
((values . _)))
;; Generic effect-free predicates.
(define-primitive-effects
((eq? . _))
((eqv? . _))
((equal? . _))
((pair? arg))
((null? arg))
((nil? arg ))
((symbol? arg))
((variable? arg))
((vector? arg))
((struct? arg))
((string? arg))
((number? arg))
((char? arg))
((bytevector? arg))
((keyword? arg))
((bitvector? arg))
((procedure? arg))
((thunk? arg)))
;; Fluids.
(define-primitive-effects
((fluid-ref f) (&read-object &fluid) &type-check)
((fluid-set! f v) (&write-object &fluid) &type-check)
((push-fluid f v) (&write-object &fluid) &type-check)
((pop-fluid) (&write-object &fluid) &type-check))
;; Prompts.
(define-primitive-effects
((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
;; Pairs.
(define-primitive-effects
((cons a b) (&allocate &pair))
((list . _) (&allocate &pair))
((car x) (&read-field &pair 0) &type-check)
((set-car! x y) (&write-field &pair 0) &type-check)
((cdr x) (&read-field &pair 1) &type-check)
((set-cdr! x y) (&write-field &pair 1) &type-check)
((memq x y) (&read-object &pair) &type-check)
((memv x y) (&read-object &pair) &type-check)
((list? arg) (&read-field &pair 1))
((length l) (&read-field &pair 1) &type-check))
;; Variables.
(define-primitive-effects
((box v) (&allocate &box))
((box-ref v) (&read-object &box) &type-check)
((box-set! v x) (&write-object &box) &type-check))
;; Vectors.
(define (vector-field n constants)
(indexed-field &vector n constants))
(define (read-vector-field n constants)
(logior &read (vector-field n constants)))
(define (write-vector-field n constants)
(logior &write (vector-field n constants)))
(define-primitive-effects* constants
((vector . _) (&allocate &vector))
((make-vector n init) (&allocate &vector) &type-check)
((make-vector/immediate n init) (&allocate &vector))
((vector-ref v n) (read-vector-field n constants) &type-check)
((vector-ref/immediate v n) (read-vector-field n constants) &type-check)
((vector-set! v n x) (write-vector-field n constants) &type-check)
((vector-set!/immediate v n x) (write-vector-field n constants) &type-check)
((vector-length v) &type-check))
;; Structs.
(define (struct-field n constants)
(indexed-field &struct n constants))
(define (read-struct-field n constants)
(logior &read (struct-field n constants)))
(define (write-struct-field n constants)
(logior &write (struct-field n constants)))
(define-primitive-effects* constants
((allocate-struct vt n) (&allocate &struct) &type-check)
((allocate-struct/immediate v n) (&allocate &struct) &type-check)
((make-struct vt ntail . _) (&allocate &struct) &type-check)
((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
((struct-ref s n) (read-struct-field n constants) &type-check)
((struct-ref/immediate s n) (read-struct-field n constants) &type-check)
((struct-set! s n x) (write-struct-field n constants) &type-check)
((struct-set!/immediate s n x) (write-struct-field n constants) &type-check)
((struct-vtable s) &type-check))
;; Strings.
(define-primitive-effects
((string-ref s n) (&read-object &string) &type-check)
((string-set! s n c) (&write-object &string) &type-check)
((number->string _) (&allocate &string) &type-check)
((string->number _) (&read-object &string) &type-check)
((string-length s) &type-check))
;; Bytevectors.
(define-primitive-effects
((bytevector-length _) &type-check)
((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
;; Modules.
(define-primitive-effects
((current-module) (&read-object &module))
((cache-current-module! m scope) (&write-object &box))
((resolve name bound?) (&read-object &module) &type-check)
((cached-toplevel-box scope name bound?) &type-check)
((cached-module-box mod name public? bound?) &type-check)
((define! name val) (&read-object &module) (&write-object &box)))
;; Numbers.
(define-primitive-effects
((= . _) &type-check)
((< . _) &type-check)
((> . _) &type-check)
((<= . _) &type-check)
((>= . _) &type-check)
((zero? . _) &type-check)
((add . _) &type-check)
((mul . _) &type-check)
((sub . _) &type-check)
((div . _) &type-check)
((sub1 . _) &type-check)
((add1 . _) &type-check)
((quo . _) &type-check)
((rem . _) &type-check)
((mod . _) &type-check)
((complex? _) &type-check)
((real? _) &type-check)
((rational? _) &type-check)
((inf? _) &type-check)
((nan? _) &type-check)
((integer? _) &type-check)
((exact? _) &type-check)
((inexact? _) &type-check)
((even? _) &type-check)
((odd? _) &type-check)
((ash n m) &type-check)
((logand . _) &type-check)
((logior . _) &type-check)
((logxor . _) &type-check)
((lognot . _) &type-check)
((logtest a b) &type-check)
((logbit? a b) &type-check)
((sqrt _) &type-check)
((abs _) &type-check))
;; Characters.
(define-primitive-effects
((char<? . _) &type-check)
((char<=? . _) &type-check)
((char>=? . _) &type-check)
((char>? . _) &type-check)
((integer->char _) &type-check)
((char->integer _) &type-check))
(define (primitive-effects constants name args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc constants args)
&all-effects)))
(define (expression-effects exp constants)
(match exp
((or ($ $const) ($ $prim) ($ $values))
&no-effects)
((or ($ $fun) ($ $rec))
(&allocate &unknown-memory-kinds))
(($ $prompt)
(&write-object &prompt))
((or ($ $call) ($ $callk))
&all-effects)
(($ $branch k exp)
(expression-effects exp constants))
(($ $primcall name args)
(primitive-effects constants name args))))
(define (compute-effects conts)
(let ((constants (compute-constant-values conts)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(expression-effects exp constants))
(($ $kreceive arity kargs)
(match arity
(($ $arity _ () #f () #f) &type-check)
(($ $arity () () _ () #f) (&allocate &pair))
(($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
(($ $kfun) &type-check)
(($ $kclause) &type-check)
(($ $ktail) &no-effects)))
conts)))
;; There is a way to abuse effects analysis in CSE to also do scalar
;; replacement, effectively adding `car' and `cdr' expressions to `cons'
;; expressions, and likewise with other constructors and setters. This
;; routine adds appropriate effects to `cons' and `set-car!' and the
;; like.
;;
;; This doesn't affect CSE's ability to eliminate expressions, given
;; that allocations aren't eliminated anyway, and the new effects will
;; just cause the allocations not to commute with e.g. set-car! which
;; is what we want anyway.
(define (synthesize-definition-effects effects)
(intmap-map (lambda (label fx)
(if (logtest (logior &write &allocation) fx)
(logior fx &read)
fx))
effects))

88
module/language/cps2/elide-values.scm
View file

@ -1,88 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Primcalls that don't correspond to VM instructions are treated as if
;;; they are calls, and indeed the later reify-primitives pass turns
;;; them into calls. Because no return arity checking is done for these
;;; primitives, if a later optimization pass simplifies the primcall to
;;; a VM operation, the tail of the simplification has to be a
;;; primcall to 'values. Most of these primcalls can be elided, and
;;; that is the job of this pass.
;;;
;;; Code:
(define-module (language cps2 elide-values)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 with-cps)
#:use-module (language cps intmap)
#:export (elide-values))
(define (inline-values cps k src args)
(match (intmap-ref cps k)
(($ $ktail)
(with-cps cps
(build-term
($continue k src ($values args)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(cond
((and (not rest) (= (length args) (length req)))
(with-cps cps
(build-term
($continue kargs src ($values args)))))
((and rest (>= (length args) (length req)))
(let ()
(define (build-rest cps k tail)
(match tail
(()
(with-cps cps
(build-term ($continue k src ($const '())))))
((v . tail)
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue k src ($primcall 'cons (v rest)))))
($ (build-rest krest tail))))))
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue kargs src
($values ,(append (list-head args (length req))
(list rest))))))
($ (build-rest krest (list-tail args (length req)))))))
(else (with-cps cps #f))))))
(define (elide-values conts)
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall 'values args)))
(call-with-values (lambda () (inline-values out k src args))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts))))

90
module/language/cps2/optimize.scm
View file

@ -1,90 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Optimizations on CPS2.
;;;
;;; Code:
(define-module (language cps2 optimize)
#:use-module (ice-9 match)
#:use-module (language cps2 constructors)
#:use-module (language cps2 contification)
#:use-module (language cps2 cse)
#:use-module (language cps2 dce)
#:use-module (language cps2 elide-values)
#:use-module (language cps2 prune-top-level-scopes)
#:use-module (language cps2 prune-bailouts)
#:use-module (language cps2 self-references)
#:use-module (language cps2 simplify)
#:use-module (language cps2 specialize-primcalls)
#:use-module (language cps2 split-rec)
#:use-module (language cps2 type-fold)
#:use-module (language cps2 verify)
#:export (optimize))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define *debug?* #f)
(define (maybe-verify program)
(if *debug?*
(verify program)
program))
(define* (optimize program #:optional (opts '()))
(define (run-pass! pass kw default)
(set! program
(if (kw-arg-ref opts kw default)
(maybe-verify (pass program))
program)))
(maybe-verify program)
;; This series of assignments to `program' used to be a series of let*
;; bindings of `program', as you would imagine. In compiled code this
;; is fine because the compiler is able to allocate all let*-bound
;; variable to the same slot, which also means that the garbage
;; collector doesn't have to retain so many copies of the term being
;; optimized. However during bootstrap, the interpreter doesn't do
;; this optimization, leading to excessive data retention as the terms
;; are rewritten. To marginally improve bootstrap memory usage, here
;; we use set! instead. The compiler should produce the same code in
;; any case, though currently it does not because it doesn't do escape
;; analysis on the box created for the set!.
(run-pass! split-rec #:split-rec? #t)
(run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
(run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t)
(run-pass! simplify #:simplify? #t)
(run-pass! contify #:contify? #t)
(run-pass! inline-constructors #:inline-constructors? #t)
(run-pass! specialize-primcalls #:specialize-primcalls? #t)
(run-pass! elide-values #:elide-values? #t)
(run-pass! prune-bailouts #:prune-bailouts? #t)
(run-pass! eliminate-common-subexpressions #:cse? #t)
(run-pass! type-fold #:type-fold? #t)
(run-pass! resolve-self-references #:resolve-self-references? #t)
(run-pass! eliminate-dead-code #:eliminate-dead-code? #t)
(run-pass! simplify #:simplify? #t)
(verify program))

86
module/language/cps2/prune-bailouts.scm
View file

@ -1,86 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; A pass that prunes successors of expressions that bail out.
;;;
;;; Code:
(define-module (language cps2 prune-bailouts)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-bailouts))
(define (compute-tails conts)
"For each LABEL->CONT entry in the intmap CONTS, compute a
LABEL->TAIL-LABEL indicating the tail continuation of each expression's
containing function. In some cases TAIL-LABEL might not be available,
for example if there is a stale $kfun pointing at a body, or for
unreferenced terms. In that case TAIL-LABEL is either absent or #f."
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kfun src meta self tail clause)
(intset-fold (lambda (label out)
(intmap-add out label tail (lambda (old new) #f)))
(compute-function-body conts label)
out))
(_ out)))
conts
empty-intmap))
(define (prune-bailout out tails k src exp)
(match (intmap-ref out k)
(($ $ktail)
(with-cps out #f))
(_
(match (intmap-ref tails k (lambda (_) #f))
(#f
(with-cps out #f))
(ktail
(with-cps out
(letv prim rest)
(letk kresult ($kargs ('rest) (rest)
($continue ktail src ($values ()))))
(letk kreceive ($kreceive '() 'rest kresult))
(build-term ($continue kreceive src ,exp))))))))
(define (prune-bailouts conts)
(let ((tails (compute-tails conts)))
(with-fresh-name-state conts
(persistent-intmap
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs names vars
($ $continue k src
(and exp ($ $primcall (or 'error 'scm-error 'throw)))))
(call-with-values (lambda () (prune-bailout out tails k src exp))
(lambda (out term)
(if term
(let ((cont (build-cont ($kargs names vars ,term))))
(intmap-replace! out label cont))
out))))
(_ out)))
conts
conts)))))

63
module/language/cps2/prune-top-level-scopes.scm
View file

@ -1,63 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2014, 2015 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:
;;;
;;; A simple pass to prune unneeded top-level scopes.
;;;
;;; Code:
(define-module (language cps2 prune-top-level-scopes)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (prune-top-level-scopes))
(define (compute-used-scopes conts constants)
(persistent-intset
(intmap-fold
(lambda (label cont used-scopes)
(match cont
(($ $kargs _ _
($ $continue k src
($ $primcall 'cached-toplevel-box (scope name bound?))))
(intset-add! used-scopes (intmap-ref constants scope)))
(_
used-scopes)))
conts
empty-intset)))
(define (prune-top-level-scopes conts)
(let* ((constants (compute-constant-values conts))
(used-scopes (compute-used-scopes conts constants)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars
($ $continue k src
($ $primcall 'cache-current-module!
(module (? (lambda (scope)
(let ((val (intmap-ref constants scope)))
(not (intset-ref used-scopes val)))))))))
(build-cont ($kargs names vars
($continue k src ($values ())))))
(_
cont)))
conts)))

205
module/language/cps2/renumber.scm
View file

@ -1,205 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; A pass to renumber variables and continuation labels so that they
;;; are contiguous within each function and, in the case of labels,
;;; topologically sorted.
;;;
;;; Code:
(define-module (language cps2 renumber)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (renumber))
(define* (compute-tail-path-lengths conts kfun preds)
(define (add-lengths labels lengths length)
(intset-fold (lambda (label lengths)
(intmap-add! lengths label length))
labels
lengths))
(define (compute-next labels lengths)
(intset-fold (lambda (label labels)
(fold1 (lambda (pred labels)
(if (intmap-ref lengths pred (lambda (_) #f))
labels
(intset-add! labels pred)))
(intmap-ref preds label)
labels))
labels
empty-intset))
(define (visit labels lengths length)
(let ((lengths (add-lengths labels lengths length)))
(values (compute-next labels lengths) lengths (1+ length))))
(match (intmap-ref conts kfun)
(($ $kfun src meta self tail clause)
(worklist-fold visit (intset-add empty-intset tail) empty-intmap 0))))
;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering.
(define (sort-labels-locally conts k0 path-lengths)
(define (visit-kf-first? kf kt)
;; Visit the successor of a branch with the shortest path length to
;; the tail first, so that if the branches are unsorted, the longer
;; path length will appear first. This will move a loop exit out of
;; a loop.
(let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f)))
(kt-len (intmap-ref path-lengths kt (lambda (_) #f))))
(if kt-len
(or (not kf-len) (< kf-len kt-len)
;; If the path lengths are the same, preserve original
;; order to avoid squirreliness.
(and (= kf-len kt-len) (< kt kf)))
(if kf-len #f (< kt kf)))))
(let ((order '())
(visited empty-intset))
(let visit ((k k0) (order '()) (visited empty-intset))
(define (visit2 k0 k1 order visited)
(let-values (((order visited) (visit k0 order visited)))
(visit k1 order visited)))
(if (intset-ref visited k)
(values order visited)
(let ((visited (intset-add visited k)))
(call-with-values
(lambda ()
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src exp))
(match exp
(($ $prompt escape? tag handler)
(visit2 k handler order visited))
(($ $branch kt)
(if (visit-kf-first? k kt)
(visit2 k kt order visited)
(visit2 kt k order visited)))
(_
(visit k order visited))))
(($ $kreceive arity k) (visit k order visited))
(($ $kclause arity kbody kalt)
(if kalt
(visit2 kalt kbody order visited)
(visit kbody order visited)))
(($ $kfun src meta self tail clause)
(if clause
(visit2 tail clause order visited)
(visit tail order visited)))
(($ $ktail) (values order visited))))
(lambda (order visited)
;; Add k to the reverse post-order.
(values (cons k order) visited))))))))
(define (compute-renaming conts kfun)
;; labels := old -> new
;; vars := old -> new
(define *next-label* -1)
(define *next-var* -1)
(define (rename-label label labels)
(set! *next-label* (1+ *next-label*))
(intmap-add! labels label *next-label*))
(define (rename-var sym vars)
(set! *next-var* (1+ *next-var*))
(intmap-add! vars sym *next-var*))
(define (rename label labels vars)
(values (rename-label label labels)
(match (intmap-ref conts label)
(($ $kargs names syms exp)
(fold1 rename-var syms vars))
(($ $kfun src meta self tail clause)
(rename-var self vars))
(_ vars))))
(define (visit-nested-funs k labels vars)
(match (intmap-ref conts k)
(($ $kargs names syms ($ $continue k src ($ $fun kfun)))
(visit-fun kfun labels vars))
(($ $kargs names syms ($ $continue k src ($ $rec names* syms*
(($ $fun kfun) ...))))
(fold2 visit-fun kfun labels vars))
(_ (values labels vars))))
(define (visit-fun kfun labels vars)
(let* ((preds (compute-predecessors conts kfun))
(path-lengths (compute-tail-path-lengths conts kfun preds))
(order (sort-labels-locally conts kfun path-lengths)))
;; First rename locally, then recurse on nested functions.
(let-values (((labels vars) (fold2 rename order labels vars)))
(fold2 visit-nested-funs order labels vars))))
(let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
(values (persistent-intmap labels) (persistent-intmap vars))))
(define* (renumber conts #:optional (kfun 0))
(let-values (((label-map var-map) (compute-renaming conts kfun)))
(define (rename-label label) (intmap-ref label-map label))
(define (rename-var var) (intmap-ref var-map var))
(define (rename-exp exp)
(rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $closure k nfree)
($closure (rename-label k) nfree))
(($ $fun body)
($fun (rename-label body)))
(($ $rec names vars funs)
($rec names (map rename-var vars) (map rename-exp funs)))
(($ $values args)
($values ,(map rename-var args)))
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
(($ $branch kt exp)
($branch (rename-label kt) ,(rename-exp exp)))
(($ $primcall name args)
($primcall name ,(map rename-var args)))
(($ $prompt escape? tag handler)
($prompt escape? (rename-var tag) (rename-label handler)))))
(define (rename-arity arity)
(match arity
(($ $arity req opt rest () aok?)
arity)
(($ $arity req opt rest kw aok?)
(match kw
(() arity)
(((kw kw-name kw-var) ...)
(let ((kw (map list kw kw-name (map rename-var kw-var))))
(make-$arity req opt rest kw aok?)))))))
(persistent-intmap
(intmap-fold
(lambda (old-k new-k out)
(intmap-add!
out
new-k
(rewrite-cont (intmap-ref conts old-k)
(($ $kargs names syms ($ $continue k src exp))
($kargs names (map rename-var syms)
($continue (rename-label k) src ,(rename-exp exp))))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (rename-label k)))
(($ $ktail)
($ktail))
(($ $kfun src meta self tail clause)
($kfun src meta (rename-var self) (rename-label tail)
(and clause (rename-label clause))))
(($ $kclause arity body alternate)
($kclause ,(rename-arity arity) (rename-label body)
(and alternate (rename-label alternate)))))))
label-map
empty-intmap))))

79
module/language/cps2/self-references.scm
View file

@ -1,79 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; A pass that replaces free references to recursive functions with
;;; bound references.
;;;
;;; Code:
(define-module (language cps2 self-references)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (resolve-self-references))
(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap))
(define (subst var)
(intmap-ref env var (lambda (var) var)))
(define (rename-exp label cps names vars k src exp)
(let ((exp (rewrite-exp exp
((or ($ $const) ($ $prim)) ,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $branch k ($ $values (arg)))
($branch k ($values ((subst arg)))))
(($ $branch k ($ $primcall name args))
($branch k ($primcall name ,(map subst args))))
(($ $values args)
($values ,(map subst args)))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))
(intmap-replace! cps label
(build-cont
($kargs names vars ($continue k src ,exp))))))
(define (visit-exp cps label names vars k src exp)
(match exp
(($ $fun label)
(resolve-self-references cps label env))
(($ $rec names vars (($ $fun labels) ...))
(fold (lambda (label var cps)
(match (intmap-ref cps label)
(($ $kfun src meta self)
(resolve-self-references cps label
(intmap-add env var self)))))
cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
(intset-fold (lambda (label cps)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp cps label names vars k src exp))
(_ cps)))
(compute-function-body cps label)
cps))

279
module/language/cps2/simplify.scm
View file

@ -1,279 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; The fundamental lambda calculus reductions, like beta and eta
;;; reduction and so on. Pretty lame currently.
;;;
;;; Code:
(define-module (language cps2 simplify)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intset)
#:use-module (language cps intmap)
#:export (simplify))
(define (intset-maybe-add! set k add?)
(if add? (intset-add! set k) set))
(define (intset-add* set k*)
(let lp ((set set) (k* k*))
(match k*
((k . k*) (lp (intset-add set k) k*))
(() set))))
(define (intset-add*! set k*)
(fold1 (lambda (k set) (intset-add! set k)) k* set))
(define (fold2* f l1 l2 seed)
(let lp ((l1 l1) (l2 l2) (seed seed))
(match (cons l1 l2)
((() . ()) seed)
(((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed))))))
(define (transform-conts f conts)
(persistent-intmap
(intmap-fold (lambda (k v out)
(let ((v* (f k v)))
(cond
((equal? v v*) out)
(v* (intmap-replace! out k v*))
(else (intmap-remove out k)))))
conts
conts)))
(define (compute-singly-referenced-vars conts)
(define (visit label cont single multiple)
(define (add-ref var single multiple)
(if (intset-ref single var)
(values single (intset-add! multiple var))
(values (intset-add! single var) multiple)))
(define (ref var) (add-ref var single multiple))
(define (ref* vars) (fold2 add-ref vars single multiple))
(match cont
(($ $kargs _ _ ($ $continue _ _ exp))
(match exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
(values single multiple))
(($ $call proc args)
(ref* (cons proc args)))
(($ $callk k proc args)
(ref* (cons proc args)))
(($ $primcall name args)
(ref* args))
(($ $values args)
(ref* args))
(($ $branch kt ($ $values (var)))
(ref var))
(($ $branch kt ($ $primcall name args))
(ref* args))
(($ $prompt escape? tag handler)
(ref tag))))
(_
(values single multiple))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold visit conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
;;; Continuations whose values are simply forwarded to another and not
;;; used in any other way may be elided via eta reduction over labels.
;;;
;;; There is an exception however: we must exclude strongly-connected
;;; components (SCCs). The only kind of SCC we can build out of $values
;;; expressions are infinite loops.
;;;
;;; Condition A below excludes single-node SCCs. Single-node SCCs
;;; cannot be reduced.
;;;
;;; Condition B conservatively excludes edges to labels already marked
;;; as candidates. This prevents back-edges and so breaks SCCs, and is
;;; optimal if labels are sorted. If the labels aren't sorted it's
;;; suboptimal but cheap.
(define (compute-eta-reductions conts kfun)
(let ((singly-used (compute-singly-referenced-vars conts)))
(define (singly-used? vars)
(match vars
(() #t)
((var . vars)
(and (intset-ref singly-used var) (singly-used? vars)))))
(define (visit-fun kfun nested-funs eta)
(let ((body (compute-function-body conts kfun)))
(define (visit-cont label nested-funs eta)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src ($ $values vars)))
(values nested-funs
(intset-maybe-add! eta label
(match (intmap-ref conts k)
(($ $kargs)
(and (not (eqv? label k)) ; A
(not (intset-ref eta label)) ; B
(singly-used? vars)))
(_ #f)))))
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(values (intset-add! nested-funs kfun) eta))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
(values (intset-add*! nested-funs kfun) eta))
(_
(values nested-funs eta))))
(intset-fold visit-cont body nested-funs eta)))
(define (visit-funs worklist eta)
(intset-fold visit-fun worklist empty-intset eta))
(persistent-intset
(worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))))
(define (eta-reduce conts kfun)
(let ((label-set (compute-eta-reductions conts kfun)))
;; Replace any continuation to a label in LABEL-SET with the label's
;; continuation. The label will denote a $kargs continuation, so
;; only terms that can continue to $kargs need be taken into
;; account.
(define (subst label)
(if (intset-ref label-set label)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k)) (subst k)))
label))
(transform-conts
(lambda (label cont)
(and (not (intset-ref label-set label))
(rewrite-cont cont
(($ $kargs names syms ($ $continue kf src ($ $branch kt exp)))
($kargs names syms
($continue (subst kf) src ($branch (subst kt) ,exp))))
(($ $kargs names syms ($ $continue k src exp))
($kargs names syms
($continue (subst k) src ,exp)))
(($ $kreceive ($ $arity req () rest () #f) k)
($kreceive req rest (subst k)))
(($ $kclause arity body alt)
($kclause ,arity (subst body) alt))
(_ ,cont))))
conts)))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k src exp))
(ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f))))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-beta-reductions conts kfun)
(define (visit-fun kfun nested-funs beta)
(let* ((body (compute-function-body conts kfun))
(single (compute-singly-referenced-labels conts body)))
(define (visit-cont label nested-funs beta)
(match (intmap-ref conts label)
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only
;; be inlined if it is used only once, and not recursively.
(($ $kargs _ _ ($ $continue k src ($ $values)))
(values nested-funs
(intset-maybe-add! beta label
(and (intset-ref single k)
(match (intmap-ref conts k)
(($ $kargs) #t)
(_ #f))))))
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(values (intset-add nested-funs kfun) beta))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...))))
(values (intset-add* nested-funs kfun) beta))
(_
(values nested-funs beta))))
(intset-fold visit-cont body nested-funs beta)))
(define (visit-funs worklist beta)
(intset-fold visit-fun worklist empty-intset beta))
(persistent-intset
(worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))
(define (compute-beta-var-substitutions conts label-set)
(define (add-var-substs label var-map)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue k _ ($ $values vals)))
(match (intmap-ref conts k)
(($ $kargs names vars)
(fold2* (lambda (var val var-map)
(intmap-add! var-map var val))
vars vals var-map))))))
(intset-fold add-var-substs label-set empty-intmap))
(define (beta-reduce conts kfun)
(let* ((label-set (compute-beta-reductions conts kfun))
(var-map (compute-beta-var-substitutions conts label-set)))
(define (subst var)
(match (intmap-ref var-map var (lambda (_) #f))
(#f var)
(val (subst val))))
(define (transform-exp label k src exp)
(if (intset-ref label-set label)
(match (intmap-ref conts k)
(($ $kargs _ _ ($ $continue k* src* exp*))
(transform-exp k k* src* exp*)))
(build-term
($continue k src
,(rewrite-exp exp
((or ($ $const) ($ $prim) ($ $fun) ($ $rec))
,exp)
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
($callk k (subst proc) ,(map subst args)))
(($ $primcall name args)
($primcall name ,(map subst args)))
(($ $values args)
($values ,(map subst args)))
(($ $branch kt ($ $values (var)))
($branch kt ($values ((subst var)))))
(($ $branch kt ($ $primcall name args))
($branch kt ($primcall name ,(map subst args))))
(($ $prompt escape? tag handler)
($prompt escape? (subst tag) handler)))))))
(transform-conts
(lambda (label cont)
(match cont
(($ $kargs names syms ($ $continue k src exp))
(build-cont
($kargs names syms ,(transform-exp label k src exp))))
(_ cont)))
conts)))
(define (simplify conts)
(eta-reduce (beta-reduce conts 0) 0))

37
module/language/cps2/spec.scm
View file

@ -1,37 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2015 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
;;; Code:
(define-module (language cps2 spec)
#:use-module (system base language)
#:use-module (language cps2)
#:use-module (language cps2 compile-cps)
#:export (cps2))
(define* (write-cps exp #:optional (port (current-output-port)))
(write (unparse-cps exp) port))
(define-language cps2
#:title "CPS2 Intermediate Language"
#:reader (lambda (port env) (read port))
#:printer write-cps
#:parser parse-cps
#:compilers `((cps . ,compile-cps))
#:for-humans? #f
)

59
module/language/cps2/specialize-primcalls.scm
View file

@ -1,59 +0,0 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013, 2014, 2015 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:
;;;
;;; Some bytecode operations can encode an immediate as an operand.
;;; This pass tranforms generic primcalls to these specialized
;;; primcalls, if possible.
;;;
;;; Code:
(define-module (language cps2 specialize-primcalls)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:export (specialize-primcalls))
(define (specialize-primcalls conts)
(let ((constants (compute-constant-values conts)))
(define (immediate-u8? var)
(let ((val (intmap-ref constants var (lambda (_) #f))))
(and (exact-integer? val) (<= 0 val 255))))
(define (specialize-primcall name args)
(match (cons name args)
(('make-vector (? immediate-u8? n) init) 'make-vector/immediate)
(('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate)
(('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate)
(('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate)
(('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate)
(('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate)
(_ #f)))
(intmap-map
(lambda (label cont)
(match cont
(($ $kargs names vars ($ $continue k src ($ $primcall name args)))
(let ((name* (specialize-primcall name args)))
(if name*
(build-cont
($kargs names vars
($continue k src ($primcall name* args))))
cont)))
(_ cont)))
conts)))

425
module/language/cps2/type-fold.scm
View file

@ -1,425 +0,0 @@
;;; Abstract constant folding on CPS
;;; Copyright (C) 2014, 2015 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/>.
;;; Commentary:
;;;
;;; This pass uses the abstract interpretation provided by type analysis
;;; to fold constant values and type predicates. It is most profitably
;;; run after CSE, to take advantage of scalar replacement.
;;;
;;; Code:
(define-module (language cps2 type-fold)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 renumber)
#:use-module (language cps2 types)
#:use-module (language cps2 with-cps)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system base target)
#:export (type-fold))
;; Branch folders.
(define &scalar-types
(logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
(define *branch-folders* (make-hash-table))
(define-syntax-rule (define-branch-folder name f)
(hashq-set! *branch-folders* 'name f))
(define-syntax-rule (define-branch-folder-alias to from)
(hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
(define-branch-folder name (lambda (arg min max) body ...)))
(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
arg1 min1 max1)
body ...)
(define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
(define-syntax-rule (define-unary-type-predicate-folder name &type)
(define-unary-branch-folder (name type min max)
(let ((type* (logand type &type)))
(cond
((zero? type*) (values #t #f))
((eqv? type type*) (values #t #t))
(else (values #f #f))))))
;; All the cases that are in compile-bytecode.
(define-unary-type-predicate-folder pair? &pair)
(define-unary-type-predicate-folder null? &null)
(define-unary-type-predicate-folder nil? &nil)
(define-unary-type-predicate-folder symbol? &symbol)
(define-unary-type-predicate-folder variable? &box)
(define-unary-type-predicate-folder vector? &vector)
(define-unary-type-predicate-folder struct? &struct)
(define-unary-type-predicate-folder string? &string)
(define-unary-type-predicate-folder number? &number)
(define-unary-type-predicate-folder char? &char)
(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
(cond
((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
(values #t #f))
((and (eqv? type0 type1)
(eqv? min0 min1 max0 max1)
(zero? (logand type0 (1- type0)))
(not (zero? (logand type0 &scalar-types))))
(values #t #t))
(else
(values #f #f))))
(define-branch-folder-alias eqv? eq?)
(define-branch-folder-alias equal? eq?)
(define (compare-ranges type0 min0 max0 type1 min1 max1)
(and (zero? (logand (logior type0 type1) (lognot &real)))
(cond ((< max0 min1) '<)
((> min0 max1) '>)
((= min0 max0 min1 max1) '=)
((<= max0 min1) '<=)
((>= min0 max1) '>=)
(else #f))))
(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((<) (values #t #t))
((= >= >) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((< <= =) (values #t #t))
((>) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
((< >) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((> >= =) (values #t #t))
((<) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((>) (values #t #t))
((= <= <) (values #t #f))
(else (values #f #f))))
(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
(define (logand-min a b)
(if (< a b 0)
(min a b)
0))
(define (logand-max a b)
(if (< a b 0)
0
(max a b)))
(if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
(values #t (logtest min0 min1))
(values #f #f)))
;; Strength reduction.
(define *primcall-reducers* (make-hash-table))
(define-syntax-rule (define-primcall-reducer name f)
(hashq-set! *primcall-reducers* 'name f))
(define-syntax-rule (define-unary-primcall-reducer (name cps k src
arg type min max)
body ...)
(define-primcall-reducer name
(lambda (cps k src arg type min max)
body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
body ...)
(define-primcall-reducer name
(lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1)
body ...)))
(define-binary-primcall-reducer (mul cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (fail) (with-cps cps #f))
(define (negate arg)
(with-cps cps
($ (with-cps-constants ((zero 0))
(build-term
($continue k src ($primcall 'sub (zero arg))))))))
(define (zero)
(with-cps cps
(build-term ($continue k src ($const 0)))))
(define (identity arg)
(with-cps cps
(build-term ($continue k src ($values (arg))))))
(define (double arg)
(with-cps cps
(build-term ($continue k src ($primcall 'add (arg arg))))))
(define (power-of-two constant arg)
(let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(with-cps cps
($ (with-cps-constants ((bits n))
(build-term ($continue k src ($primcall 'ash (arg bits)))))))))
(define (mul/constant constant constant-type arg arg-type)
(cond
((not (or (= constant-type &exact-integer) (= constant-type arg-type)))
(fail))
((eqv? constant -1)
;; (* arg -1) -> (- 0 arg)
(negate arg))
((eqv? constant 0)
;; (* arg 0) -> 0 if arg is not a flonum or complex
(and (= constant-type &exact-integer)
(zero? (logand arg-type
(lognot (logior &flonum &complex))))
(zero)))
((eqv? constant 1)
;; (* arg 1) -> arg
(identity arg))
((eqv? constant 2)
;; (* arg 2) -> (+ arg arg)
(double arg))
((and (= constant-type arg-type &exact-integer)
(positive? constant)
(zero? (logand constant (1- constant))))
;; (* arg power-of-2) -> (ash arg (log2 power-of-2
(power-of-two constant arg))
(else
(fail))))
(cond
((logtest (logior type0 type1) (lognot &number)) (fail))
((= min0 max0) (mul/constant min0 type0 arg1 type1))
((= min1 max1) (mul/constant min1 type1 arg0 type0))
(else (fail))))
(define-binary-primcall-reducer (logbit? cps k src
arg0 type0 min0 max0
arg1 type1 min1 max1)
(define (convert-to-logtest cps kbool)
(define (compute-mask cps kmask src)
(if (eq? min0 max0)
(with-cps cps
(build-term
($continue kmask src ($const (ash 1 min0)))))
(with-cps cps
($ (with-cps-constants ((one 1))
(build-term
($continue kmask src ($primcall 'ash (one arg0)))))))))
(with-cps cps
(letv mask)
(letk kt ($kargs () ()
($continue kbool src ($const #t))))
(letk kf ($kargs () ()
($continue kbool src ($const #f))))
(letk kmask ($kargs (#f) (mask)
($continue kf src
($branch kt ($primcall 'logtest (mask arg1))))))
($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown
;; arity to a branching primcall.
(let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
(if (and (= type0 &exact-integer)
(<= 0 min0 positive-fixnum-bits)
(<= 0 max0 positive-fixnum-bits))
(match (intmap-ref cps k)
(($ $kreceive arity kargs)
(match arity
(($ $arity (_) () (not #f) () #f)
(with-cps cps
(letv bool)
(let$ body (with-cps-constants ((nil '()))
(build-term
($continue kargs src ($values (bool nil))))))
(letk kbool ($kargs (#f) (bool) ,body))
($ (convert-to-logtest kbool))))
(_
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'values (bool)))))
($ (convert-to-logtest kbool))))))
(($ $ktail)
(with-cps cps
(letv bool)
(letk kbool ($kargs (#f) (bool)
($continue k src ($primcall 'return (bool)))))
($ (convert-to-logtest kbool)))))
(with-cps cps #f))))
;;
(define (local-type-fold start end cps)
(define (scalar-value type val)
(cond
((eqv? type &exact-integer) val)
((eqv? type &flonum) (exact->inexact val))
((eqv? type &char) (integer->char val))
((eqv? type &unspecified) *unspecified*)
((eqv? type &false) #f)
((eqv? type &true) #t)
((eqv? type &nil) #nil)
((eqv? type &null) '())
(else (error "unhandled type" type val))))
(let ((types (infer-types cps start)))
(define (fold-primcall cps label names vars k src name args def)
(call-with-values (lambda () (lookup-post-type types label def 0))
(lambda (type min max)
(and (not (zero? type))
(zero? (logand type (1- type)))
(zero? (logand type (lognot &scalar-types)))
(eqv? min max)
(let ((val (scalar-value type min)))
;; (pk 'folded src name args val)
(with-cps cps
(letv v*)
(letk k* ($kargs (#f) (v*)
($continue k src ($const val))))
;; Rely on DCE to elide this expression, if
;; possible.
(setk label
($kargs names vars
($continue k* src ($primcall name args))))))))))
(define (reduce-primcall cps label names vars k src name args)
(and=>
(hashq-ref *primcall-reducers* name)
(lambda (reducer)
(match args
((arg0)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))
((arg0 arg1)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(reducer cps k src arg0 type0 min0 max0
arg1 type1 min1 max1))
(lambda (cps term)
(and term
(with-cps cps
(setk label ($kargs names vars ,term)))))))))))
(_ #f)))))
(define (fold-unary-branch cps label names vars kf kt src name arg)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg))
(lambda (type min max)
(call-with-values (lambda () (folder type min max))
(lambda (f? v)
;; (when f? (pk 'folded-unary-branch label name arg v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))
(define (fold-binary-branch cps label names vars kf kt src name arg0 arg1)
(and=>
(hashq-ref *branch-folders* name)
(lambda (folder)
(call-with-values (lambda () (lookup-pre-type types label arg0))
(lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type types label arg1))
(lambda (type1 min1 max1)
(call-with-values (lambda ()
(folder type0 min0 max0 type1 min1 max1))
(lambda (f? v)
;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v))
(and f?
(with-cps cps
(setk label
($kargs names vars
($continue (if v kt kf) src
($values ())))))))))))))))
(define (visit-expression cps label names vars k src exp)
(match exp
(($ $primcall name args)
;; We might be able to fold primcalls that define a value.
(match (intmap-ref cps k)
(($ $kargs (_) (def))
(or (fold-primcall cps label names vars k src name args def)
(reduce-primcall cps label names vars k src name args)
cps))
(_
(or (reduce-primcall cps label names vars k src name args)
cps))))
(($ $branch kt ($ $primcall name args))
;; We might be able to fold primcalls that branch.
(match args
((x)
(or (fold-unary-branch cps label names vars k kt src name x)
cps))
((x y)
(or (fold-binary-branch cps label names vars k kt src name x y)
cps))))
(_ cps)))
(let lp ((label start) (cps cps))
(if (<= label end)
(lp (1+ label)
(match (intmap-ref cps label)
(($ $kargs names vars ($ $continue k src exp))
(visit-expression cps label names vars k src exp))
(_ cps)))
cps))))
(define (fold-functions-in-renumbered-program f conts seed)
(let* ((conts (persistent-intmap conts))
(end (1+ (intmap-prev conts))))
(let lp ((label 0) (seed seed))
(if (eqv? label end)
seed
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
(lp (1+ tail) (f label tail seed))))))))
(define (type-fold conts)
;; Type analysis wants a program whose labels are sorted.
(let ((conts (renumber conts)))
(with-fresh-name-state conts
(persistent-intmap
(fold-functions-in-renumbered-program local-type-fold conts conts)))))

1407
module/language/cps2/types.scm
View file

File diff suppressed because it is too large Load diff

303
module/language/cps2/verify.scm
View file

@ -1,303 +0,0 @@
;;; Diagnostic checker for CPS
;;; Copyright (C) 2014, 2015 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/>.
;;; Commentary:
;;;
;;; A routine to detect invalid CPS.
;;;
;;; Code:
(define-module (language cps2 verify)
#:use-module (ice-9 match)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (language cps primitives)
#:use-module (srfi srfi-11)
#:export (verify))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define-syntax-rule (make-worklist-folder* seed ...)
(lambda (f worklist seed ...)
(let lp ((worklist worklist) (seed seed) ...)
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist i)
(if i
(call-with-values (lambda () (f i seed ...))
(lambda (i* seed ...)
(let add ((i* i*) (worklist worklist))
(match i*
(() (lp worklist seed ...))
((i . i*) (add i* (intset-add worklist i)))))))
(values seed ...)))))))
(define worklist-fold*
(case-lambda
((f worklist seed)
((make-worklist-folder* seed) f worklist seed))))
(define (check-distinct-vars conts)
(define (adjoin-def var seen)
(when (intset-ref seen var)
(error "duplicate var name" seen var))
(intset-add seen var))
(intmap-fold
(lambda (label cont seen)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(fold1 adjoin-def vars seen))
(($ $kfun src meta self tail clause)
(adjoin-def self seen))
(_ seen))
)
conts
empty-intset))
(define (compute-available-definitions conts kfun)
"Compute and return a map of LABEL->VAR..., where VAR... are the
definitions that are available at LABEL."
(define (adjoin-def var defs)
(when (intset-ref defs var)
(error "var already present in defs" defs var))
(intset-add defs var))
(define (propagate defs succ out)
(let* ((in (intmap-ref defs succ (lambda (_) #f)))
(in* (if in (intset-intersect in out) out)))
(if (eq? in in*)
(values '() defs)
(values (list succ)
(intmap-add defs succ in* (lambda (old new) new))))))
(define (visit-cont label defs)
(let ((in (intmap-ref defs label)))
(define (propagate0 out)
(values '() defs))
(define (propagate1 succ out)
(propagate defs succ out))
(define (propagate2 succ0 succ1 out)
(let*-values (((changed0 defs) (propagate defs succ0 out))
((changed1 defs) (propagate defs succ1 out)))
(values (append changed0 changed1) defs)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(let ((out (fold1 adjoin-def vars in)))
(match exp
(($ $branch kt) (propagate2 k kt out))
(($ $prompt escape? tag handler) (propagate2 k handler out))
(_ (propagate1 k out)))))
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
(let ((out (adjoin-def self in)))
(if clause
(propagate1 clause out)
(propagate0 out))))
(($ $kclause arity kbody kalt)
(if kalt
(propagate2 kbody kalt in)
(propagate1 kbody in)))
(($ $ktail) (propagate0 in)))))
(worklist-fold* visit-cont
(intset kfun)
(intmap-add empty-intmap kfun empty-intset)))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
(define (check-valid-var-uses conts kfun)
(define (adjoin-def var defs) (intset-add defs var))
(let visit-fun ((kfun kfun) (free empty-intset))
(define (visit-exp exp bound)
(define (check-use var)
(unless (intset-ref bound var)
(error "unbound var" var)))
(match exp
((or ($ $const) ($ $prim)) #t)
;; todo: $closure
(($ $fun kfun)
(visit-fun kfun bound))
(($ $rec names vars (($ $fun kfuns) ...))
(let ((bound (fold1 adjoin-def vars bound)))
(for-each (lambda (kfun) (visit-fun kfun bound)) kfuns)))
(($ $values args)
(for-each check-use args))
(($ $call proc args)
(check-use proc)
(for-each check-use args))
(($ $callk k proc args)
(check-use proc)
(for-each check-use args))
(($ $branch kt ($ $values (arg)))
(check-use arg))
(($ $branch kt ($ $primcall name args))
(for-each check-use args))
(($ $primcall name args)
(for-each check-use args))
(($ $prompt escape? tag handler)
(check-use tag))))
(intmap-for-each
(lambda (label bound)
(let ((bound (intset-union free bound)))
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
(visit-exp exp (fold1 adjoin-def vars bound)))
(_ #t))))
(compute-available-definitions conts kfun))))
(define (fold-nested-funs f conts kfun seed)
(intset-fold
(lambda (label seed)
(match (intmap-ref conts label)
(($ $kargs _ _ ($ $continue _ _ ($ $fun label)))
(f label seed))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun label) ...))))
(fold1 f label seed))
(_ seed)))
(compute-function-body conts kfun)
seed))
(define (check-label-partition conts kfun)
;; A continuation can only belong to one function.
(let visit-fun ((kfun kfun) (seen empty-intmap))
(fold-nested-funs
visit-fun
conts
kfun
(intset-fold
(lambda (label seen)
(intmap-add seen label kfun
(lambda (old new)
(error "label used by two functions" label old new))))
(compute-function-body conts kfun)
seen))))
(define (compute-reachable-labels conts kfun)
(let visit-fun ((kfun kfun) (seen empty-intset))
(fold-nested-funs visit-fun conts kfun
(intset-union seen (compute-function-body conts kfun)))))
(define (check-arities conts kfun)
(define (check-arity exp cont)
(define (assert-unary)
(match cont
(($ $kargs (_) (_)) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-nullary)
(match cont
(($ $kargs () ()) #t)
(_ (error "expected unary continuation" cont))))
(define (assert-n-ary n)
(match cont
(($ $kargs names vars)
(unless (= (length vars) n)
(error "expected n-ary continuation" n cont)))
(_ (error "expected $kargs continuation" cont))))
(define (assert-kreceive-or-ktail)
(match cont
((or ($ $kreceive) ($ $ktail)) #t)
(_ (error "expected $kreceive or $ktail continuation" cont))))
(match exp
((or ($ $const) ($ $prim) ($ $closure) ($ $fun))
(assert-unary))
(($ $rec names vars funs)
(unless (= (length names) (length vars) (length funs))
(error "invalid $rec" exp))
(assert-n-ary (length names))
(match cont
(($ $kargs names vars*)
(unless (equal? vars* vars)
(error "bound variable mismatch" vars vars*)))))
(($ $values args)
(match cont
(($ $ktail) #t)
(_ (assert-n-ary (length args)))))
(($ $call proc args)
(assert-kreceive-or-ktail))
(($ $callk k proc args)
(assert-kreceive-or-ktail))
(($ $branch kt exp)
(assert-nullary)
(match (intmap-ref conts kt)
(($ $kargs () ()) #t)
(cont (error "bad kt" cont))))
(($ $primcall name args)
(match cont
(($ $kargs names)
(match (prim-arity name)
((out . in)
(unless (= in (length args))
(error "bad arity to primcall" name args in))
(unless (= out (length names))
(error "bad return arity from primcall" name names out)))))
(($ $kreceive)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $kreceive" name)))
(($ $ktail)
(unless (eq? name 'return)
(when (false-if-exception (prim-arity name))
(error "primitive should continue to $kargs, not $ktail" name))))))
(($ $prompt escape? tag handler)
(assert-nullary)
(match (intmap-ref conts handler)
(($ $kreceive) #t)
(cont (error "bad handler" cont))))))
(let ((reachable (compute-reachable-labels conts kfun)))
(intmap-for-each
(lambda (label cont)
(when (intset-ref reachable label)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(unless (= (length names) (length vars))
(error "broken $kargs" label names vars))
(check-arity exp (intmap-ref conts k)))
(_ #t))))
conts)))
(define (check-functions-bound-once conts kfun)
(let ((reachable (compute-reachable-labels conts kfun)))
(define (add-fun fun functions)
(when (intset-ref functions fun)
(error "function already bound" fun))
(intset-add functions fun))
(intmap-fold
(lambda (label cont functions)
(if (intset-ref reachable label)
(match cont
(($ $kargs _ _ ($ $continue _ _ ($ $fun kfun)))
(add-fun kfun functions))
(($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
(fold1 add-fun kfuns functions))
(_ functions))
functions))
conts
empty-intset)))
(define (verify conts)
(check-distinct-vars conts)
(check-label-partition conts 0)
(check-valid-var-uses conts 0)
(check-arities conts 0)
(check-functions-bound-once conts 0)
conts)

8
module/language/ecmascript/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; ECMAScript for Guile
;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2011, 2016 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
@ -437,9 +437,9 @@
((^= ,what ,val)
(comp `(= ,what (^ ,what ,val)) e))
((new ,what ,args)
(@impl new
(map (lambda (x) (comp x e))
(cons what args))))
`(call ,(@implv new)
,(comp what e)
,@(map (lambda (x) (comp x e)) args)))
((delete (pref ,obj ,prop))
(@impl pdel
(comp obj e)

70
module/language/tree-il/analyze.scm
View file

@ -35,6 +35,7 @@
unused-variable-analysis
unused-toplevel-analysis
unbound-variable-analysis
macro-use-before-definition-analysis
arity-analysis
format-analysis))
@ -895,14 +896,75 @@ given `tree-il' element."
(lambda (toplevel env)
;; Post-process the result.
(vlist-for-each (lambda (name+loc)
(let ((name (car name+loc))
(loc (cdr name+loc)))
(warning 'unbound-variable loc name)))
(vlist-for-each (match-lambda
((name . loc)
(warning 'unbound-variable loc name)))
(vlist-reverse (toplevel-info-refs toplevel))))
(make-toplevel-info vlist-null vlist-null)))
;;;
;;; Macro use-before-definition analysis.
;;;
;; <macro-use-info> records are used during tree traversal in search of
;; possibly uses of macros before they are defined. They contain a list
;; of references to top-level variables, and a list of the top-level
;; macro definitions that have been encountered. Any definition which
;; is a macro should in theory be expanded out already; if that's not
;; the case, the program likely has a bug.
(define-record-type <macro-use-info>
(make-macro-use-info uses defs)
macro-use-info?
(uses macro-use-info-uses) ;; ((VARIABLE-NAME . LOCATION) ...)
(defs macro-use-info-defs)) ;; ((VARIABLE-NAME . LOCATION) ...)
(define macro-use-before-definition-analysis
;; Report possibly unbound variables in the given tree.
(make-tree-analysis
(lambda (x info env locs)
;; Going down into X.
(define (nearest-loc src)
(or src (find pair? locs)))
(define (add-use name src)
(match info
(($ <macro-use-info> uses defs)
(make-macro-use-info (vhash-consq name src uses) defs))))
(define (add-def name src)
(match info
(($ <macro-use-info> uses defs)
(make-macro-use-info uses (vhash-consq name src defs)))))
(define (macro? x)
(match x
(($ <primcall> _ 'make-syntax-transformer) #t)
(_ #f)))
(match x
(($ <toplevel-ref> src name)
(add-use name (nearest-loc src)))
(($ <toplevel-set> src name)
(add-use name (nearest-loc src)))
(($ <toplevel-define> src name (? macro?))
(add-def name (nearest-loc src)))
(_ info)))
(lambda (x info env locs)
;; Leaving X's scope.
info)
(lambda (info env)
;; Post-process the result.
(match info
(($ <macro-use-info> uses defs)
(vlist-for-each
(match-lambda
((name . use-loc)
(when (vhash-assq name defs)
(warning 'macro-use-before-definition use-loc name))))
(vlist-reverse (macro-use-info-uses info))))))
(make-macro-use-info vlist-null vlist-null)))
;;;
;;; Arity analysis.

190
module/language/tree-il/compile-cps2.scm → module/language/tree-il/compile-cps.scm
View file

@ -49,20 +49,20 @@
;;;
;;; Code:
(define-module (language tree-il compile-cps2)
(define-module (language tree-il compile-cps)
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold filter-map))
#:use-module (srfi srfi-26)
#:use-module ((system foreign) #:select (make-pointer pointer->scm))
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps2 with-cps)
#:use-module (language cps)
#:use-module (language cps utils)
#:use-module (language cps with-cps)
#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language cps intmap)
#:export (compile-cps2))
#:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
;;; the current module, and that all contained lambdas use that module
@ -249,7 +249,7 @@
(with-cps cps
(let$ body (with-cps-constants ((unspecified *unspecified*))
(build-term
($continue k src ($primcall 'return (unspecified))))))
($continue k src ($values (unspecified))))))
(letk kvoid ($kargs () () ,body))
kvoid))
(($ $kreceive arity kargs)
@ -287,7 +287,7 @@
(with-cps cps
(letv val)
(letk kval ($kargs ('val) (val)
($continue k src ($primcall 'return (val)))))
($continue k src ($values (val)))))
kval))
(($ $kreceive arity kargs)
(match arity
@ -460,7 +460,7 @@
(($ <module-set> src mod name public? exp)
(convert-arg cps exp
(lambda (val)
(lambda (cps val)
(module-box
cps src mod name public? #t
(lambda (cps box)
@ -493,9 +493,12 @@
(lambda (cps val)
(with-cps cps
(let$ k (adapt-arity k src 0))
(letv box)
(letk kset ($kargs ('box) (box)
($continue k src ($primcall 'box-set! (box val)))))
($ (with-cps-constants ((name name))
(build-term
($continue k src ($primcall 'define! (name val))))))))))
($continue kset src ($primcall 'define! (name))))))))))
(($ <call> src proc args)
(convert-args cps (cons proc args)
@ -506,6 +509,18 @@
(($ <primcall> src name args)
(cond
((eq? name 'equal?)
(convert-args cps args
(lambda (cps args)
(with-cps cps
(let$ k* (adapt-arity k src 1))
(letk kt ($kargs () () ($continue k* src ($const #t))))
(letk kf* ($kargs () ()
;; Here we continue to the original $kreceive
;; or $ktail, as equal? doesn't have a VM op.
($continue k src ($primcall 'equal? args))))
(build-term ($continue kf* src
($branch kt ($primcall 'eqv? args))))))))
((branching-primitive? name)
(convert-args cps args
(lambda (cps args)
@ -555,6 +570,117 @@
($ (lp args ktail)))))))))))
((prim-instruction name)
=> (lambda (instruction)
(define (box+adapt-arity cps k src out)
(case instruction
((bv-f32-ref bv-f64-ref)
(with-cps cps
(letv f64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('f64) (f64)
($continue k src ($primcall 'f64->scm (f64)))))
kbox))
((char->integer
string-length vector-length
bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
(with-cps cps
(letv u64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('u64) (u64)
($continue k src ($primcall 'u64->scm (u64)))))
kbox))
((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref)
(with-cps cps
(letv s64)
(let$ k (adapt-arity k src out))
(letk kbox ($kargs ('s64) (s64)
($continue k src ($primcall 's64->scm (s64)))))
kbox))
(else
(adapt-arity cps k src out))))
(define (unbox-arg cps arg unbox-op have-arg)
(with-cps cps
(letv unboxed)
(let$ body (have-arg unboxed))
(letk kunboxed ($kargs ('unboxed) (unboxed) ,body))
(build-term
($continue kunboxed src ($primcall unbox-op (arg))))))
(define (unbox-args cps args have-args)
(case instruction
((bv-f32-ref bv-f64-ref
bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref
bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
(match args
((bv idx)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(have-args cps (list bv idx)))))))
((bv-f32-set! bv-f64-set!)
(match args
((bv idx val)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(unbox-arg
cps val 'scm->f64
(lambda (cps val)
(have-args cps (list bv idx val)))))))))
((bv-s8-set! bv-s16-set! bv-s32-set! bv-s64-set!)
(match args
((bv idx val)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(unbox-arg
cps val 'scm->s64
(lambda (cps val)
(have-args cps (list bv idx val)))))))))
((bv-u8-set! bv-u16-set! bv-u32-set! bv-u64-set!)
(match args
((bv idx val)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(unbox-arg
cps val 'scm->u64
(lambda (cps val)
(have-args cps (list bv idx val)))))))))
((vector-ref struct-ref string-ref)
(match args
((obj idx)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(have-args cps (list obj idx)))))))
((vector-set! struct-set! string-set!)
(match args
((obj idx val)
(unbox-arg
cps idx 'scm->u64
(lambda (cps idx)
(have-args cps (list obj idx val)))))))
((make-vector)
(match args
((length init)
(unbox-arg
cps length 'scm->u64
(lambda (cps length)
(have-args cps (list length init)))))))
((allocate-struct)
(match args
((vtable nfields)
(unbox-arg
cps nfields 'scm->u64
(lambda (cps nfields)
(have-args cps (list vtable nfields)))))))
((integer->char)
(match args
((integer)
(unbox-arg
cps integer 'scm->u64
(lambda (cps integer)
(have-args cps (list integer)))))))
(else (have-args cps args))))
(convert-args cps args
(lambda (cps args)
;; Tree-IL primcalls are sloppy, in that it could be
@ -566,10 +692,14 @@
((out . in)
(if (= in (length args))
(with-cps cps
(let$ k (adapt-arity k src out))
(build-term
($continue k src
($primcall instruction args))))
(let$ k (box+adapt-arity k src out))
($ (unbox-args
args
(lambda (cps args)
(with-cps cps
(build-term
($continue k src
($primcall instruction args))))))))
(with-cps cps
(letv prim)
(letk kprim ($kargs ('prim) (prim)
@ -653,7 +783,7 @@
(build-term ($continue k src ($primcall 'apply args*)))))))
(($ <conditional> src test consequent alternate)
(define (convert-test cps kt kf)
(define (convert-test cps test kt kf)
(match test
(($ <primcall> src (? branching-primitive? name) args)
(convert-args cps args
@ -661,6 +791,13 @@
(with-cps cps
(build-term ($continue kf src
($branch kt ($primcall name args))))))))
(($ <conditional> src test consequent alternate)
(with-cps cps
(let$ t (convert-test consequent kt kf))
(let$ f (convert-test alternate kt kf))
(letk kt* ($kargs () () ,t))
(letk kf* ($kargs () () ,f))
($ (convert-test test kt* kf*))))
(_ (convert-arg cps test
(lambda (cps test)
(with-cps cps
@ -671,7 +808,7 @@
(let$ f (convert alternate k subst))
(letk kt ($kargs () () ,t))
(letk kf ($kargs () () ,f))
($ (convert-test kt kf))))
($ (convert-test test kt kf))))
(($ <lexical-set> src name gensym exp)
(convert-arg cps exp
@ -818,11 +955,12 @@ integer."
(define *comp-module* (make-fluid))
(define %warning-passes
`((unused-variable . ,unused-variable-analysis)
(unused-toplevel . ,unused-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
(arity-mismatch . ,arity-analysis)
(format . ,format-analysis)))
`((unused-variable . ,unused-variable-analysis)
(unused-toplevel . ,unused-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
(macro-use-before-definition . ,macro-use-before-definition-analysis)
(arity-mismatch . ,arity-analysis)
(format . ,format-analysis)))
(define (optimize-tree-il x e opts)
(define warnings
@ -892,6 +1030,16 @@ integer."
(make-lexical-ref src 'v v)))
(make-lexical-ref src 'v v)))))
;; Lower (logand x (lognot y)) to (logsub x y). We do it here
;; instead of in CPS because it gets rid of the lognot entirely;
;; if type folding can't prove Y to be an exact integer, then DCE
;; would have to leave it in the program for its possible
;; effects.
(($ <primcall> src 'logand (x ($ <primcall> _ 'lognot (y))))
(make-primcall src 'logsub (list x y)))
(($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x))
(make-primcall src 'logsub (list x y)))
(($ <prompt> src escape-only? tag body
($ <lambda> hsrc hmeta
($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
@ -931,7 +1079,7 @@ integer."
(_ exp)))
exp))
(define (compile-cps2 exp env opts)
(define (compile-cps exp env opts)
(values (cps-convert/thunk
(canonicalize (optimize-tree-il exp env opts)))
env

8
module/language/tree-il/effects.scm
View file

@ -360,6 +360,14 @@ of an expression."
(($ <primcall> _ 'pop-fluid ())
(logior (cause &fluid)))
(($ <primcall> _ 'push-dynamic-state (state))
(logior (compute-effects state)
(cause &type-check)
(cause &fluid)))
(($ <primcall> _ 'pop-dynamic-state ())
(logior (cause &fluid)))
(($ <primcall> _ 'car (x))
(logior (compute-effects x)
(cause &type-check)

6
module/language/tree-il/fix-letrec.scm
View file

@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 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
@ -272,7 +272,9 @@
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(let ((tmps (map (lambda (x)
(module-gensym "fixlr"))
c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(list->seq

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

@ -1,6 +1,6 @@
;;; Tree-il optimizer
;; Copyright (C) 2009, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2011, 2012, 2013, 2014, 2015 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,7 +25,8 @@
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
#:export (optimize))
#:export (optimize
tree-il-default-optimization-options))
(define (optimize x env opts)
(let ((peval (match (memq #:partial-eval? opts)
@ -37,3 +38,6 @@
(verify-tree-il
(peval (expand-primitives (resolve-primitives x env))
env)))))
(define (tree-il-default-optimization-options)
'(#:partial-eval? #t))

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

@ -92,7 +92,6 @@
(define (singly-valued-expression? exp)
(match exp
(($ <const>) #t)
(($ <lexical-ref>) #t)
(($ <void>) #t)
(($ <lexical-ref>) #t)
(($ <primitive-ref>) #t)
@ -511,7 +510,15 @@ top-level bindings from ENV and return the resulting expression."
(lambda ()
(call-with-values
(lambda ()
(apply (module-ref the-scm-module name) args))
(case name
((eq? eqv?)
;; Constants will be deduplicated later, but eq?
;; folding can happen now. Anticipate the
;; deduplication by using equal? instead of eq?.
;; Same for eqv?.
(apply equal? args))
(else
(apply (module-ref the-scm-module name) args))))
(lambda results
(values #t results))))
(lambda _
@ -944,26 +951,35 @@ top-level bindings from ENV and return the resulting expression."
(map lookup-alias vals)))
(env (fold extend-env env gensyms ops))
(body (loop body env counter ctx)))
(cond
((const? body)
(for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
(list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
(else
;; Only include bindings for which lexical references
;; have been residualized.
(prune-bindings ops #f body counter ctx
(lambda (names gensyms vals body)
(if (null? names) (error "what!" names))
(make-let src names gensyms vals body)))))))
(match body
(($ <const>)
(for-tail (list->seq src (append vals (list body)))))
(($ <lexical-ref> _ _ (? (lambda (sym) (memq sym new)) sym))
(let ((pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
(list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
((and ($ <conditional> src*
($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym) alt)
(? (lambda (_)
(case ctx
((test effect)
(and (equal? (list sym) new)
(= (lexical-refcount sym) 2)))
(else #f)))))
;; (let ((x EXP)) (if x x ALT)) -> (if EXP #t ALT) in test context
(make-conditional src* (visit-operand (car ops) counter 'test)
(make-const src* #t) alt))
(_
;; Only include bindings for which lexical references
;; have been residualized.
(prune-bindings ops #f body counter ctx
(lambda (names gensyms vals body)
(if (null? names) (error "what!" names))
(make-let src names gensyms vals body)))))))
(($ <letrec> src in-order? names gensyms vals body)
;; Note the difference from the `let' case: here we use letrec*
;; so that the `visit' procedure for the new operands closes over
@ -1005,10 +1021,6 @@ top-level bindings from ENV and return the resulting expression."
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer)))
(or (match consumer
(($ <lambda-case> src (req-name) #f #f #f () (req-sym) body #f)
(for-tail
(make-let src (list req-name) (list req-sym) (list producer)
body)))
((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f)
(? (lambda _ (singly-valued-expression? producer))))
(let ((tmp (gensym "tmp ")))
@ -1084,6 +1096,30 @@ top-level bindings from ENV and return the resulting expression."
subsequent alternate)
(simplify-conditional
(make-conditional src pred alternate subsequent)))
;; In the following four cases, we try to expose the test to
;; the conditional. This will let the CPS conversion avoid
;; reifying boolean literals in some cases.
(($ <conditional> src ($ <let> src* names vars vals body)
subsequent alternate)
(make-let src* names vars vals
(simplify-conditional
(make-conditional src body subsequent alternate))))
(($ <conditional> src
($ <letrec> src* in-order? names vars vals body)
subsequent alternate)
(make-letrec src* in-order? names vars vals
(simplify-conditional
(make-conditional src body subsequent alternate))))
(($ <conditional> src ($ <fix> src* names vars vals body)
subsequent alternate)
(make-fix src* names vars vals
(simplify-conditional
(make-conditional src body subsequent alternate))))
(($ <conditional> src ($ <seq> src* head tail)
subsequent alternate)
(make-seq src* head
(simplify-conditional
(make-conditional src tail subsequent alternate))))
;; Special cases for common tests in the predicates of chains
;; of if expressions.
(($ <conditional> src
@ -1183,6 +1219,19 @@ top-level bindings from ENV and return the resulting expression."
(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
'()))))))))
(($ <primcall> src 'values exps)
(cond
((null? exps)
@ -1357,7 +1406,8 @@ top-level bindings from ENV and return the resulting expression."
(let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
(($ <primitive-ref> _ name)
(for-tail (make-primcall src name orig-args)))
(for-tail
(expand-primcall (make-primcall src name orig-args))))
(($ <lambda> _ _
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no keyword arguments.

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

@ -21,13 +21,14 @@
(define-module (language tree-il primitives)
#:use-module (system base pmatch)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives add-interesting-primitive!
expand-primitives
expand-primcall expand-primitives
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive?
singly-valued-primitive? equality-primitive?
@ -83,7 +84,7 @@
current-module define!
fluid-ref fluid-set! with-fluid*
current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state
call-with-prompt
abort-to-prompt* abort-to-prompt
@ -171,7 +172,7 @@
not
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
bytevector? keyword? bitvector?
bytevector? keyword? bitvector? atomic-box?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
@ -194,7 +195,7 @@
pair? null? nil? list?
symbol? variable? vector? struct? string? number? char?
bytevector? keyword? bitvector?
procedure? thunk?
procedure? thunk? atomic-box?
acons cons cons* list vector))
;; Primitives that don't always return one value.
@ -313,16 +314,16 @@
(define *primitive-expand-table* (make-hash-table))
(define (expand-primcall x)
(record-case x
((<primcall> src name args)
(let ((expand (hashq-ref *primitive-expand-table* name)))
(or (and expand (apply expand src args))
x)))
(else x)))
(define (expand-primitives x)
(pre-order
(lambda (x)
(record-case x
((<primcall> src name args)
(let ((expand (hashq-ref *primitive-expand-table* name)))
(or (and expand (apply expand src args))
x)))
(else x)))
x))
(pre-order expand-primcall x))
;;; I actually did spend about 10 minutes trying to redo this with
;;; syntax-rules. Patches appreciated.
@ -388,18 +389,16 @@
;; FIXME: All the code that uses `const?' is redundant with `peval'.
(define-primitive-expander 1+ (x)
(+ x 1))
(define-primitive-expander 1- (x)
(- x 1))
(define-primitive-expander +
() 0
(x) (values x)
(x y) (if (and (const? y) (eqv? (const-exp y) 1))
(1+ x)
(if (and (const? y) (eqv? (const-exp y) -1))
(1- x)
(if (and (const? x) (eqv? (const-exp x) 1))
(1+ y)
(if (and (const? x) (eqv? (const-exp x) -1))
(1- y)
(+ x y)))))
(x y) (+ x y)
(x y z ... last) (+ (+ x y . z) last))
(define-primitive-expander *
@ -409,9 +408,7 @@
(define-primitive-expander -
(x) (- 0 x)
(x y) (if (and (const? y) (eqv? (const-exp y) 1))
(1- x)
(- x y))
(x y) (- x y)
(x y z ... last) (- (- x y . z) last))
(define-primitive-expander /
@ -553,6 +550,24 @@
(chained-comparison-expander prim-name)))
'(< > <= >= =))
(define (character-comparison-expander char< <)
(lambda (src . args)
(expand-primcall
(make-primcall src <
(map (lambda (arg)
(make-primcall src 'char->integer (list arg)))
args)))))
(for-each (match-lambda
((char< . <)
(hashq-set! *primitive-expand-table* char<
(character-comparison-expander char< <))))
'((char<? . <)
(char>? . >)
(char<=? . <=)
(char>=? . >=)
(char=? . =)))
;; Appropriate for use with either 'eqv?' or 'equal?'.
(define (maybe-simplify-to-eq prim)
(case-lambda
@ -583,7 +598,12 @@
(define (expand-chained-comparisons prim)
(case-lambda
((src) (make-const src #t))
((src a) (make-const src #t))
((src a)
;; (< x) -> (begin (< x 0) #t). Residualizes side-effects from x
;; and, for numeric comparisons, checks that x is a number.
(make-seq src
(make-primcall src prim (list a (make-const src 0)))
(make-const src #t)))
((src a b) #f)
((src a b . rest)
(make-conditional src (make-primcall src prim (list a b))

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

@ -1,6 +1,6 @@
;;; Tree Intermediate Language
;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011, 2013, 2015 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,7 +22,7 @@
#:use-module (system base language)
#:use-module (system base pmatch)
#:use-module (language tree-il)
#:use-module (language tree-il compile-cps2)
#:use-module (language tree-il compile-cps)
#:export (tree-il))
(define (write-tree-il exp . port)
@ -42,5 +42,5 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
#:compilers `((cps2 . ,compile-cps2))
#:compilers `((cps . ,compile-cps))
#:for-humans? #f)

18
module/oop/goops.scm
View file

@ -62,7 +62,7 @@
<boolean> <char> <list> <pair> <null> <string> <symbol>
<vector> <bytevector> <uvec> <foreign> <hashtable>
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
<keyword>
<keyword> <syntax> <atomic-box>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
@ -74,8 +74,8 @@
;; corresponding classes, which may be obtained via class-of,
;; once you have an instance. Perhaps FIXME to provide a
;; smob-type-name->class procedure.
<arbiter> <promise> <thread> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state> <async>
<promise> <thread> <mutex> <condition-variable>
<regexp> <hook> <bitvector> <random-state>
<directory> <array> <character-set>
<dynamic-object> <guardian> <macro>
@ -765,7 +765,7 @@ slots as we go."
(define (slot-protection-and-kind slot)
(define (subclass? class parent)
(memq parent (class-precedence-list class)))
(let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))
(let ((type (get-keyword #:class (%slot-definition-options slot))))
(if (and type (subclass? type <foreign-slot>))
(values (cond
((subclass? type <self-slot>) #\s)
@ -1009,6 +1009,8 @@ slots as we go."
(define-standard-class <integer> (<real>))
(define-standard-class <fraction> (<real>))
(define-standard-class <keyword> (<top>))
(define-standard-class <syntax> (<top>))
(define-standard-class <atomic-box> (<top>))
(define-standard-class <unknown> (<top>))
(define-standard-class <procedure> (<applicable>)
#:metaclass <procedure-class>)
@ -1332,7 +1334,7 @@ function."
#`(case-lambda
#,@(build-clauses #'(arg ...))
(args (apply miss args)))))))
(arity-case (vector-length fv) 20 dispatch
(arity-case (1- (vector-length fv)) 20 dispatch
(lambda args
(let ((nargs (length args)))
(if (< nargs (vector-length fv))
@ -3095,7 +3097,10 @@ var{initargs}."
;;; {SMOB and port classes}
;;;
(define <arbiter> (find-subclass <top> '<arbiter>))
(begin-deprecated
(define-public <arbiter> (find-subclass <top> '<arbiter>))
(define-public <async> (find-subclass <top> '<async>)))
(define <promise> (find-subclass <top> '<promise>))
(define <thread> (find-subclass <top> '<thread>))
(define <mutex> (find-subclass <top> '<mutex>))
@ -3104,7 +3109,6 @@ var{initargs}."
(define <hook> (find-subclass <top> '<hook>))
(define <bitvector> (find-subclass <top> '<bitvector>))
(define <random-state> (find-subclass <top> '<random-state>))
(define <async> (find-subclass <top> '<async>))
(define <directory> (find-subclass <top> '<directory>))
(define <array> (find-subclass <top> '<array>))
(define <character-set> (find-subclass <top> '<character-set>))

10
module/rnrs.scm
View file

@ -160,11 +160,17 @@
;; (rnrs io ports)
file-options buffer-mode buffer-mode?
&i/o-decoding i/o-decoding-error?
make-i/o-decoding-error
&i/o-encoding i/o-encoding-error-char i/o-encoding-error?
make-i/o-encoding-error
file-options buffer-mode buffer-mode?
eol-style native-eol-style error-handling-mode
make-transcoder transcoder-codec transcoder-eol-style
transcoder-error-handling-mode native-transcoder
latin-1-codec utf-8-codec utf-16-codec
string->bytevector bytevector->string
eof-object? port? input-port? output-port? eof-object port-eof?
port-transcoder
@ -183,7 +189,7 @@
open-file-input-port open-file-output-port open-file-input/output-port
make-custom-textual-output-port
call-with-string-output-port
flush-output-port put-string
output-port-buffer-mode flush-output-port put-string
get-char get-datum get-line get-string-all get-string-n get-string-n!
lookahead-char
put-char put-datum put-string

28
module/rnrs/arithmetic/fixnums.scm
View file

@ -242,28 +242,50 @@
(define (fxcopy-bit fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-copy-bit fx1 fx2 fx3))
(define (fxbit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-bit-field fx1 fx2 fx3))
(define (fxcopy-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-copy-bit-field fx1 fx2 fx3 fx4))
(define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2))
(define fxarithmetic-shift-left fxarithmetic-shift)
(define (fxarithmetic-shift fx1 fx2)
(assert-fixnum fx1 fx2)
(unless (< (abs fx2) (fixnum-width))
(raise (make-assertion-violation)))
(ash fx1 fx2))
(define (fxarithmetic-shift-left fx1 fx2)
(assert-fixnum fx1 fx2)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(ash fx1 fx2))
(define (fxarithmetic-shift-right fx1 fx2)
(assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
(assert-fixnum fx1 fx2)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(ash fx1 (- fx2)))
(define (fxrotate-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)) (< fx4 (- fx3 fx2)))
(raise (make-assertion-violation)))
(bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
(define (fxreverse-bit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-reverse-bit-field fx1 fx2 fx3))
)

27
module/rnrs/hashtables.scm
View file

@ -74,8 +74,9 @@
(make-record-type-descriptor
'r6rs:hashtable #f #f #t #t
'#((mutable wrapped-table)
(immutable orig-hash-function)
(immutable mutable))))
(immutable orig-hash-function)
(immutable mutable)
(immutable type))))
(define hashtable? (record-predicate r6rs:hashtable))
(define make-r6rs-hashtable
@ -85,6 +86,7 @@
(define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
(define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
(define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
(define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
(define hashtable-mutable? r6rs:hashtable-mutable?)
@ -96,13 +98,15 @@
(make-r6rs-hashtable
(if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
symbol-hash
#t))
#t
'eq))
(define* (make-eqv-hashtable #:optional k)
(make-r6rs-hashtable
(if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
hash-by-value
#t))
#t
'eqv))
(define* (make-hashtable hash-function equiv #:optional k)
(let ((wrapped-hash-function (wrap-hash-function hash-function)))
@ -111,7 +115,8 @@
(make-hash-table equiv wrapped-hash-function k)
(make-hash-table equiv wrapped-hash-function))
hash-function
#t)))
#t
'custom)))
(define (hashtable-size hashtable)
(hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
@ -122,8 +127,9 @@
(define (hashtable-set! hashtable key obj)
(if (r6rs:hashtable-mutable? hashtable)
(hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
*unspecified*)
(hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)
(assertion-violation
'hashtable-set! "Hashtable is immutable." hashtable)))
(define (hashtable-delete! hashtable key)
(if (r6rs:hashtable-mutable? hashtable)
@ -143,7 +149,8 @@
(make-r6rs-hashtable
(hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
(r6rs:hashtable-orig-hash-function hashtable)
(and mutable #t)))
(and mutable #t)
(r6rs:hashtable-type hashtable)))
(define* (hashtable-clear! hashtable #:optional k)
(if (r6rs:hashtable-mutable? hashtable)
@ -178,4 +185,6 @@
(hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
(define (hashtable-hash-function hashtable)
(r6rs:hashtable-orig-hash-function hashtable)))
(case (r6rs:hashtable-type hashtable)
((eq eqv) #f)
(else (r6rs:hashtable-orig-hash-function hashtable)))))

65
module/rnrs/io/ports.scm
View file

@ -36,6 +36,9 @@
transcoder-error-handling-mode native-transcoder
latin-1-codec utf-8-codec utf-16-codec
;; transcoding bytevectors
bytevector->string string->bytevector
;; input & output ports
port? input-port? output-port?
port-eof?
@ -63,10 +66,12 @@
call-with-bytevector-output-port
call-with-string-output-port
make-custom-textual-output-port
output-port-buffer-mode
flush-output-port
;; input/output ports
open-file-input/output-port
make-custom-binary-input/output-port
;; binary output
put-u8 put-bytevector
@ -100,12 +105,16 @@
make-i/o-file-does-not-exist-error
&i/o-port i/o-port-error? make-i/o-port-error
i/o-error-port
&i/o-decoding-error i/o-decoding-error?
&i/o-decoding i/o-decoding-error?
make-i/o-decoding-error
&i/o-encoding-error i/o-encoding-error?
&i/o-encoding i/o-encoding-error?
make-i/o-encoding-error i/o-encoding-error-char)
(import (ice-9 binary-ports)
(only (rnrs base) assertion-violation)
(only (ice-9 ports internal)
port-write-buffer port-buffer-bytevector port-line-buffered?)
(only (rnrs bytevectors) bytevector-length)
(prefix (ice-9 iconv) iconv:)
(rnrs enums)
(rnrs records syntactic)
(rnrs exceptions)
@ -167,6 +176,33 @@
(define (utf-16-codec)
"UTF-16")
;;;
;;; Transcoding bytevectors
;;;
(define (string->bytevector str transcoder)
"Encode @var{str} using @var{transcoder}, returning a bytevector."
(iconv:string->bytevector
str
(transcoder-codec transcoder)
(case (transcoder-error-handling-mode transcoder)
((raise) 'error)
((replace) 'substitute)
(else (error "unsupported error handling mode"
(transcoder-error-handling-mode transcoder))))))
(define (bytevector->string bv transcoder)
"Decode @var{bv} using @var{transcoder}, returning a string."
(iconv:bytevector->string
bv
(transcoder-codec transcoder)
(case (transcoder-error-handling-mode transcoder)
((raise) 'error)
((replace) 'substitute)
(else (error "unsupported error handling mode"
(transcoder-error-handling-mode transcoder))))))
;;;
;;; Internal helpers
@ -310,8 +346,9 @@ read from/written to in @var{port}."
(lambda ()
(with-fluids ((%default-port-encoding #f))
(open filename mode))))))
(cond (transcoder
(set-port-encoding! port (transcoder-codec transcoder))))
(setvbuf port buffer-mode)
(when transcoder
(set-port-encoding! port (transcoder-codec transcoder)))
port))
(define (file-options->mode file-options base-mode)
@ -350,7 +387,11 @@ read from/written to in @var{port}."
as a string, and a thunk to retrieve the characters associated with that port."
(let ((port (open-output-string)))
(values port
(lambda () (get-output-string port)))))
(lambda ()
(let ((s (get-output-string port)))
(seek port 0 SEEK_SET)
(truncate-file port 0)
s)))))
(define* (open-file-output-port filename
#:optional
@ -382,6 +423,16 @@ return the characters accumulated in that port."
close)
"w"))
(define (output-port-buffer-mode port)
"Return @code{none} if @var{port} is unbuffered, @code{line} if it is
line buffered, or @code{block} otherwise."
(let ((buffering (bytevector-length
(port-buffer-bytevector (port-write-buffer port)))))
(cond
((= buffering 1) 'none)
((port-line-buffered? port) 'line)
(else 'block))))
(define (flush-output-port port)
(force-output port))
@ -396,7 +447,7 @@ return the characters accumulated in that port."
(define-syntax with-i/o-encoding-error
(syntax-rules ()
"Convert Guile throws to `encoding-error' to `&i/o-encoding-error'."
"Convert Guile throws to `encoding-error' to `&i/o-encoding'."
((_ body ...)
;; XXX: This is heavyweight for small functions like `put-char'.
(with-throw-handler 'encoding-error
@ -437,7 +488,7 @@ return the characters accumulated in that port."
(define-syntax with-i/o-decoding-error
(syntax-rules ()
"Convert Guile throws to `decoding-error' to `&i/o-decoding-error'."
"Convert Guile throws to `decoding-error' to `&i/o-decoding'."
((_ body ...)
;; XXX: This is heavyweight for small functions like `get-char' and
;; `lookahead-char'.

77
module/scripts/compile.scm
View file

@ -1,6 +1,6 @@
;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc.
;; Copyright 2005, 2008-2011, 2013, 2014, 2015 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@ -32,10 +32,13 @@
#:use-module ((system base compile) #:select (compile-file))
#:use-module (system base target)
#:use-module (system base message)
#:use-module (language tree-il optimize)
#:use-module (language cps optimize)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-37)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (compile))
(define %summary "Compile a file.")
@ -45,6 +48,20 @@
(format (current-error-port) "error: ~{~a~}~%" messages)
(exit 1))
(define (available-optimizations)
(append (tree-il-default-optimization-options)
(cps-default-optimization-options)))
;; Turn on all optimizations unless -O0.
(define (optimizations-for-level level)
(let lp ((options (available-optimizations)))
(match options
(() '())
((#:partial-eval? val . options)
(cons* #:partial-eval? (> level 0) (lp options)))
((kw val . options)
(cons* kw (> level 1) (lp options))))))
(define %options
;; Specifications of the command-line options.
(list (option '(#\h "help") #f #f
@ -77,9 +94,28 @@
(cons (string->symbol arg) warnings)
(alist-delete 'warnings result))))))
(option '(#\O "optimize") #f #f
(option '(#\O "optimize") #t #f
(lambda (opt name arg result)
(alist-cons 'optimize? #t result)))
(define (return val)
(alist-cons 'optimizations val result))
(define (return-option name val)
(let ((kw (symbol->keyword
(string->symbol (string-append name "?")))))
(unless (memq kw (available-optimizations))
(fail "Unknown optimization pass `~a'" name))
(return (list kw val))))
(cond
((string=? arg "help")
(show-optimization-help)
(exit 0))
((equal? arg "0") (return (optimizations-for-level 0)))
((equal? arg "1") (return (optimizations-for-level 1)))
((equal? arg "2") (return (optimizations-for-level 2)))
((equal? arg "3") (return (optimizations-for-level 3)))
((string-prefix? "no-" arg)
(return-option (substring arg 3) #f))
(else
(return-option arg #t)))))
(option '(#\f "from") #t #f
(lambda (opt name arg result)
(if (assoc-ref result 'from)
@ -129,15 +165,38 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
%warning-types)
(format #t "~%"))
(define (show-optimization-help)
(format #t "The available optimizations are:~%~%")
(let lp ((options (available-optimizations)))
(match options
(() #t)
((kw val . options)
(let ((name (string-trim-right (symbol->string (keyword->symbol kw))
#\?)))
(format #t " -O~a~%"
(if val name (string-append "no-" name)))
(lp options)))))
(format #t "~%")
(format #t "To disable an optimization, prepend it with `no-', for example~%")
(format #t "`-Ono-cse.'~%~%")
(format #t "You may also specify optimization levels as `-O0', `-O1',~%")
(format #t "`-O2', or `-O3'. Currently `-O0' turns off all optimizations,~%")
(format #t "`-O1' turns on partial evaluation, and `-O2' and `-O3' turn on~%")
(format #t "everything. The default is equivalent to `-O2'.")
(format #t "~%"))
(define (compile . args)
(let* ((options (parse-args args))
(help? (assoc-ref options 'help?))
(compile-opts (let ((o `(#:warnings
,(assoc-ref options 'warnings))))
(if (assoc-ref options 'optimize?)
(cons #:O o)
o)))
(compile-opts `(#:warnings
,(assoc-ref options 'warnings)
,@(append-map
(lambda (opt)
(match opt
(('optimizations . opts) opts)
(_ '())))
options)))
(from (or (assoc-ref options 'from) 'scheme))
(to (or (assoc-ref options 'to) 'bytecode))
(target (or (assoc-ref options 'target) %host-type))
@ -156,6 +215,8 @@ Compile each Guile source file FILE into a Guile object.
-W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
for a list of available warnings
-O, --optimize=OPT specify optimization passes to run; use `-Ohelp'
for a list of available optimizations
-f, --from=LANG specify a source language other than `scheme'
-t, --to=LANG specify a target language other than `bytecode'

519
module/srfi/srfi-18.scm
View file

@ -31,66 +31,67 @@
;;; Code:
(define-module (srfi srfi-18)
:use-module (srfi srfi-34)
:export (
#:use-module ((ice-9 threads) #:prefix threads:)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module ((srfi srfi-34) #:prefix srfi-34:)
#:use-module ((srfi srfi-35) #:select (define-condition-type
&error
condition))
#:export (;; Threads
make-thread
thread-name
thread-specific
thread-specific-set!
thread-start!
thread-yield!
thread-sleep!
thread-terminate!
thread-join!
;;; Threads
;; current-thread <= in the core
;; thread? <= in the core
make-thread
thread-name
thread-specific
thread-specific-set!
thread-start!
thread-yield!
thread-sleep!
thread-terminate!
thread-join!
;; Mutexes
make-mutex
mutex
mutex-name
mutex-specific
mutex-specific-set!
mutex-state
mutex-lock!
mutex-unlock!
;;; Mutexes
;; mutex? <= in the core
make-mutex
mutex-name
mutex-specific
mutex-specific-set!
mutex-state
mutex-lock!
mutex-unlock!
;; Condition variables
make-condition-variable
condition-variable-name
condition-variable-specific
condition-variable-specific-set!
condition-variable-signal!
condition-variable-broadcast!
;;; Condition variables
;; condition-variable? <= in the core
make-condition-variable
condition-variable-name
condition-variable-specific
condition-variable-specific-set!
condition-variable-signal!
condition-variable-broadcast!
condition-variable-wait!
;;; Time
current-time
time?
time->seconds
seconds->time
;; Time
current-time
time?
time->seconds
seconds->time
current-exception-handler
with-exception-handler
raise
join-timeout-exception?
abandoned-mutex-exception?
terminated-thread-exception?
uncaught-exception?
uncaught-exception-reason
)
:re-export (current-thread thread? mutex? condition-variable?)
:replace (current-time
make-thread
make-mutex
make-condition-variable
raise))
current-exception-handler
with-exception-handler
join-timeout-exception?
abandoned-mutex-exception?
terminated-thread-exception?
uncaught-exception?
uncaught-exception-reason)
#:re-export ((srfi-34:raise . raise))
#:replace (current-time
current-thread
thread?
make-thread
make-mutex
mutex?
make-condition-variable
condition-variable?))
(if (not (provided? 'threads))
(error "SRFI-18 requires Guile with threads support"))
(unless (provided? 'threads)
(error "SRFI-18 requires Guile with threads support"))
(cond-expand-provide (current-module) '(srfi-18))
@ -100,72 +101,68 @@
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
(define join-timeout-exception (list 'join-timeout-exception))
(define terminated-thread-exception (list 'terminated-thread-exception))
(define uncaught-exception (list 'uncaught-exception))
(define-condition-type &abandoned-mutex-exception &error
abandoned-mutex-exception?)
(define-condition-type &join-timeout-exception &error
join-timeout-exception?)
(define-condition-type &terminated-thread-exception &error
terminated-thread-exception?)
(define-condition-type &uncaught-exception &error
uncaught-exception?
(reason uncaught-exception-reason))
(define object-names (make-weak-key-hash-table))
(define object-specifics (make-weak-key-hash-table))
(define thread-start-conds (make-weak-key-hash-table))
(define thread-exception-handlers (make-weak-key-hash-table))
(define-record-type <mutex>
(%make-mutex prim name specific owner abandoned?)
mutex?
(prim mutex-prim)
(name mutex-name)
(specific mutex-specific mutex-specific-set!)
(owner mutex-owner set-mutex-owner!)
(abandoned? mutex-abandoned? set-mutex-abandoned?!))
(define-record-type <condition-variable>
(%make-condition-variable prim name specific)
condition-variable?
(prim condition-variable-prim)
(name condition-variable-name)
(specific condition-variable-specific condition-variable-specific-set!))
(define-record-type <thread>
(%make-thread prim name specific start-conds exception)
thread?
(prim thread-prim set-thread-prim!)
(name thread-name)
(specific thread-specific thread-specific-set!)
(start-conds thread-start-conds set-thread-start-conds!)
(exception thread-exception set-thread-exception!))
(define current-thread (make-parameter (%make-thread #f #f #f #f #f)))
(define thread-mutexes (make-parameter #f))
;; EXCEPTIONS
(define raise (@ (srfi srfi-34) raise))
(define (initial-handler obj)
(srfi-18-exception-preserver (cons uncaught-exception obj)))
;; All threads created by SRFI-18 have an initial handler installed that
;; will squirrel away an uncaught exception to allow it to bubble out to
;; joining threads. However for the main thread and other threads not
;; created by SRFI-18, just let the exception bubble up by passing on
;; doing anything with the exception.
(define (exception-handler-for-foreign-threads obj)
(values))
(define thread->exception (make-object-property))
(define (srfi-18-exception-preserver obj)
(if (or (terminated-thread-exception? obj)
(uncaught-exception? obj))
(set! (thread->exception (current-thread)) obj)))
(define (srfi-18-exception-handler key . args)
;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
;; if one is caught at this level, it has already been taken care of by
;; `initial-handler'.
(and (not (eq? key 'srfi-34))
(srfi-18-exception-preserver (if (null? args)
(cons uncaught-exception key)
(cons* uncaught-exception key args)))))
(define (current-handler-stack)
(let ((ct (current-thread)))
(or (hashq-ref thread-exception-handlers ct)
(hashq-set! thread-exception-handlers ct (list initial-handler)))))
(define current-exception-handler
(make-parameter exception-handler-for-foreign-threads))
(define (with-exception-handler handler thunk)
(let ((ct (current-thread))
(hl (current-handler-stack)))
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(hashq-set! thread-exception-handlers ct (cons handler hl))
((@ (srfi srfi-34) with-exception-handler)
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(srfi-34:with-exception-handler
(let ((prev-handler (current-exception-handler)))
(lambda (obj)
(hashq-set! thread-exception-handlers ct hl)
(handler obj))
(lambda ()
(call-with-values thunk
(lambda res
(hashq-set! thread-exception-handlers ct hl)
(apply values res)))))))
(define (current-exception-handler)
(car (current-handler-stack)))
(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
(define (uncaught-exception? obj)
(and (pair? obj) (eq? (car obj) uncaught-exception)))
(define (uncaught-exception-reason exc)
(cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
(define (terminated-thread-exception? obj)
(eq? obj terminated-thread-exception))
(parameterize ((current-exception-handler prev-handler))
(handler obj))))
(lambda ()
(parameterize ((current-exception-handler handler))
(thunk)))))
;; THREADS
@ -173,59 +170,59 @@
;; Once started, install a top-level exception handler that rethrows any
;; exceptions wrapped in an uncaught-exception wrapper.
(define make-thread
(let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
(lambda ()
(lock-mutex lmutex)
(signal-condition-variable lcond)
(lock-mutex smutex)
(unlock-mutex lmutex)
(wait-condition-variable scond smutex)
(unlock-mutex smutex)
(with-exception-handler initial-handler
thunk)))))
(lambda (thunk . name)
(let ((n (and (pair? name) (car name)))
(define (with-thread-mutex-cleanup thunk)
(let ((mutexes (make-weak-key-hash-table)))
(dynamic-wind
values
(lambda ()
(parameterize ((thread-mutexes mutexes))
(thunk)))
(lambda ()
(let ((thread (current-thread)))
(hash-for-each (lambda (mutex _)
(when (eq? (mutex-owner mutex) thread)
(abandon-mutex! mutex)))
mutexes))))))
(lm (make-mutex 'launch-mutex))
(lc (make-condition-variable 'launch-condition-variable))
(sm (make-mutex 'start-mutex))
(sc (make-condition-variable 'start-condition-variable)))
(lock-mutex lm)
(let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
srfi-18-exception-handler)))
(hashq-set! thread-start-conds t (cons sm sc))
(and n (hashq-set! object-names t n))
(wait-condition-variable lc lm)
(unlock-mutex lm)
t)))))
(define (thread-name thread)
(hashq-ref object-names (check-arg-type thread? thread "thread-name")))
(define (thread-specific thread)
(hashq-ref object-specifics
(check-arg-type thread? thread "thread-specific")))
(define (thread-specific-set! thread obj)
(hashq-set! object-specifics
(check-arg-type thread? thread "thread-specific-set!")
obj)
*unspecified*)
(define* (make-thread thunk #:optional name)
(let* ((sm (make-mutex 'start-mutex))
(sc (make-condition-variable 'start-condition-variable))
(thread (%make-thread #f name #f (cons sm sc) #f)))
(mutex-lock! sm)
(let ((prim (threads:call-with-new-thread
(lambda ()
(catch #t
(lambda ()
(parameterize ((current-thread thread))
(with-thread-mutex-cleanup
(lambda ()
(mutex-lock! sm)
(condition-variable-signal! sc)
(mutex-unlock! sm sc)
(thunk)))))
(lambda (key . args)
(set-thread-exception!
thread
(condition (&uncaught-exception
(reason
(match (cons key args)
(('srfi-34 obj) obj)
(obj obj))))))))))))
(set-thread-prim! thread prim)
(mutex-unlock! sm sc)
thread)))
(define (thread-start! thread)
(let ((x (hashq-ref thread-start-conds
(check-arg-type thread? thread "thread-start!"))))
(and x (let ((smutex (car x))
(scond (cdr x)))
(hashq-remove! thread-start-conds thread)
(lock-mutex smutex)
(signal-condition-variable scond)
(unlock-mutex smutex)))
thread))
(match (thread-start-conds thread)
((smutex . scond)
(set-thread-start-conds! thread #f)
(mutex-lock! smutex)
(condition-variable-signal! scond)
(mutex-unlock! smutex))
(#f #f))
thread)
(define (thread-yield!) (yield) *unspecified*)
(define (thread-yield!) (threads:yield) *unspecified*)
(define (thread-sleep! timeout)
(let* ((ct (time->seconds (current-time)))
@ -237,129 +234,119 @@
'()))))
(secs (inexact->exact (truncate t)))
(usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
(and (> secs 0) (sleep secs))
(and (> usecs 0) (usleep usecs))
(when (> secs 0) (sleep secs))
(when (> usecs 0) (usleep usecs))
*unspecified*))
;; A convenience function for installing exception handlers on SRFI-18
;; primitives that resume the calling continuation after the handler is
;; invoked -- this resolves a behavioral incompatibility with Guile's
;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
;; exceptions. (SRFI-18, "Primitives and exceptions")
;; Whereas SRFI-34 leaves the continuation of a call to an exception
;; handler unspecified, SRFI-18 has this to say:
;;
;; When one of the primitives defined in this SRFI raises an exception
;; defined in this SRFI, the exception handler is called with the same
;; continuation as the primitive (i.e. it is a tail call to the
;; exception handler).
;;
;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run
;; handlers with the continuation of the primitive call, for those
;; primitives that throw exceptions.
(define (wrap thunk)
(lambda (continuation)
(with-exception-handler (lambda (obj)
((current-exception-handler) obj)
(continuation))
thunk)))
;; A pass-thru to cancel-thread that first installs a handler that throws
;; terminated-thread exception, as per SRFI-18,
(define (with-exception-handlers-here thunk)
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(lambda ()
(with-exception-handler (lambda (exn) (abort-to-prompt tag exn))
thunk))
(lambda (k exn)
((current-exception-handler) exn)))))
;; A unique value.
(define %cancel-sentinel (list 'cancelled))
(define (thread-terminate! thread)
(define (thread-terminate-inner!)
(let ((current-handler (thread-cleanup thread)))
(if (thunk? current-handler)
(set-thread-cleanup! thread
(lambda ()
(with-exception-handler initial-handler
current-handler)
(srfi-18-exception-preserver
terminated-thread-exception)))
(set-thread-cleanup! thread
(lambda () (srfi-18-exception-preserver
terminated-thread-exception))))
(cancel-thread thread)
*unspecified*))
(thread-terminate-inner!))
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
(let ((v (apply join-thread thread args))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
(if e (raise e))
v))))
(call/cc thread-join-inner!))
;; MUTEXES
;; These functions are all pass-thrus to the existing Guile implementations.
(define make-mutex
(lambda name
(let ((n (and (pair? name) (car name)))
(m ((@ (guile) make-mutex)
'unchecked-unlock
'allow-external-unlock
'recursive)))
(and n (hashq-set! object-names m n)) m)))
(define (mutex-name mutex)
(hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
(define (mutex-specific mutex)
(hashq-ref object-specifics
(check-arg-type mutex? mutex "mutex-specific")))
(define (mutex-specific-set! mutex obj)
(hashq-set! object-specifics
(check-arg-type mutex? mutex "mutex-specific-set!")
obj)
(threads:cancel-thread (thread-prim thread) %cancel-sentinel)
*unspecified*)
;; A unique value.
(define %timeout-sentinel (list 1))
(define* (thread-join! thread #:optional (timeout %timeout-sentinel)
(timeoutval %timeout-sentinel))
(let ((t (thread-prim thread)))
(with-exception-handlers-here
(lambda ()
(let* ((v (if (eq? timeout %timeout-sentinel)
(threads:join-thread t)
(threads:join-thread t timeout %timeout-sentinel))))
(cond
((eq? v %timeout-sentinel)
(if (eq? timeoutval %timeout-sentinel)
(srfi-34:raise (condition (&join-timeout-exception)))
timeoutval))
((eq? v %cancel-sentinel)
(srfi-34:raise (condition (&terminated-thread-exception))))
((thread-exception thread) => srfi-34:raise)
(else v)))))))
;; MUTEXES
(define* (make-mutex #:optional name)
(%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f))
(define (mutex-state mutex)
(let ((owner (mutex-owner mutex)))
(if owner
(if (thread-exited? owner) 'abandoned owner)
(if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
(cond
((mutex-abandoned? mutex) 'abandoned)
((mutex-owner mutex))
((> (threads:mutex-level (mutex-prim mutex)) 0) 'not-owned)
(else 'not-abandoned)))
(define (mutex-lock! mutex . args)
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
(lambda () (apply lock-mutex mutex args))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (abandon-mutex! mutex)
(set-mutex-abandoned?! mutex #t)
(threads:unlock-mutex (mutex-prim mutex)))
(define (mutex-unlock! mutex . args)
(apply unlock-mutex mutex args))
(define* (mutex-lock! mutex #:optional timeout (thread (current-thread)))
(let ((mutexes (thread-mutexes)))
(when mutexes
(hashq-set! mutexes mutex #t)))
(with-exception-handlers-here
(lambda ()
(cond
((threads:lock-mutex (mutex-prim mutex) timeout)
(set-mutex-owner! mutex thread)
(when (mutex-abandoned? mutex)
(set-mutex-abandoned?! mutex #f)
(srfi-34:raise
(condition (&abandoned-mutex-exception))))
#t)
(else #f)))))
(define %unlock-sentinel (list 'unlock))
(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)
(timeout %unlock-sentinel))
(when (mutex-owner mutex)
(set-mutex-owner! mutex #f)
(cond
((eq? cond-var %unlock-sentinel)
(threads:unlock-mutex (mutex-prim mutex)))
((eq? timeout %unlock-sentinel)
(threads:wait-condition-variable (condition-variable-prim cond-var)
(mutex-prim mutex))
(threads:unlock-mutex (mutex-prim mutex)))
((threads:wait-condition-variable (condition-variable-prim cond-var)
(mutex-prim mutex)
timeout)
(threads:unlock-mutex (mutex-prim mutex)))
(else #f))))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
(define make-condition-variable
(lambda name
(let ((n (and (pair? name) (car name)))
(m ((@ (guile) make-condition-variable))))
(and n (hashq-set! object-names m n)) m)))
(define (condition-variable-name condition-variable)
(hashq-ref object-names (check-arg-type condition-variable?
condition-variable
"condition-variable-name")))
(define (condition-variable-specific condition-variable)
(hashq-ref object-specifics (check-arg-type condition-variable?
condition-variable
"condition-variable-specific")))
(define (condition-variable-specific-set! condition-variable obj)
(hashq-set! object-specifics
(check-arg-type condition-variable?
condition-variable
"condition-variable-specific-set!")
obj)
*unspecified*)
(define* (make-condition-variable #:optional name)
(%make-condition-variable (threads:make-condition-variable) name #f))
(define (condition-variable-signal! cond)
(signal-condition-variable cond)
(threads:signal-condition-variable (condition-variable-prim cond))
*unspecified*)
(define (condition-variable-broadcast! cond)
(broadcast-condition-variable cond)
(threads:broadcast-condition-variable (condition-variable-prim cond))
*unspecified*)
;; TIME

42
module/srfi/srfi-19.scm
View file

@ -1,7 +1,7 @@
;;; srfi-19.scm --- Time/Date Library
;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010,
;; 2011, 2014 Free Software Foundation, Inc.
;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2017
;; 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
@ -203,7 +203,8 @@
;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
;; note they go higher to lower, and end in 1972.
(define leap-second-table
'((1341100800 . 35)
'((1435708800 . 36)
(1341100800 . 35)
(1230768000 . 34)
(1136073600 . 33)
(915148800 . 32)
@ -332,8 +333,11 @@
;; of course.
(define (current-time-monotonic)
;; Resolution is microseconds.
(current-time-tai))
;; Guile monotonic and TAI times are the same.
(let ((tai (current-time-tai)))
(make-time time-monotonic
(time-nanosecond tai)
(time-second tai))))
(define (current-time-thread)
(time-error 'current-time 'unsupported-clock-type 'time-thread))
@ -1001,24 +1005,14 @@
#\Space 2)
port)))
(cons #\f (lambda (date pad-with port)
(if (> (date-nanosecond date)
nano)
(display (padding (+ (date-second date) 1)
pad-with 2)
port)
(display (padding (date-second date)
pad-with 2)
port))
(receive (i f)
(split-real (/
(date-nanosecond date)
nano 1.0))
(let* ((ns (number->string f))
(le (string-length ns)))
(if (> le 2)
(begin
(display (locale-decimal-point) port)
(display (substring ns 2 le) port)))))))
(receive (s ns) (floor/ (+ (* (date-second date) nano)
(date-nanosecond date))
nano)
(display (number->string s) port)
(display (locale-decimal-point) port)
(let ((str (padding ns #\0 9)))
(display (substring str 0 1) port)
(display (string-trim-right str #\0 1) port)))))
(cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port)
@ -1059,7 +1053,7 @@
(newline port)))
(cons #\N (lambda (date pad-with port)
(display (padding (date-nanosecond date)
pad-with 7)
pad-with 9)
port)))
(cons #\p (lambda (date pad-with port)
(display (locale-am-string/pm (date-hour date)) port)))

6
module/srfi/srfi-34.scm
View file

@ -41,9 +41,9 @@ procedure that accepts one argument. It is installed as the current
exception handler for the dynamic extent (as determined by
dynamic-wind) of the invocation of THUNK."
(with-throw-handler throw-key
thunk
(lambda (key obj)
(handler obj))))
thunk
(lambda (key obj)
(handler obj))))
(define (raise obj)
"Invokes the current exception handler on OBJ. The handler is

3
module/srfi/srfi-37.scm
View file

@ -217,7 +217,8 @@ program-arguments in ARGS, as decided by the OPTIONS'
(if (null? args)
(apply values seeds)
(let ((arg (car args)))
(cond ((or (not (char=? #\- (string-ref arg 0)))
(cond ((or (string-null? arg)
(not (char=? #\- (string-ref arg 0)))
(= 1 (string-length arg))) ;"-"
(mutate-seeds! operand-proc arg)
(set! args (cdr args)))

Some files were not shown because too many files have changed in this diff Show more