From 75bce2810b3e89414c446f13ccabb97117db5449 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Thu, 24 May 2018 18:48:29 -0400 Subject: [PATCH 01/18] flush expand-output and expand/optimize-output ports original commit: 39a1aa4034dc11e808146e5a3ed44acfc1f0f99b --- LOG | 2 ++ s/compile.ss | 12 ++++++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/LOG b/LOG index 086540306a..a4ed4474fd 100644 --- a/LOG +++ b/LOG @@ -997,3 +997,5 @@ whose base and/or index is a local save. cpnanopass.ss, misc.ms +- flush expand-output and expand/optimize-output ports + compile.ss diff --git a/s/compile.ss b/s/compile.ss index c526bae7fe..10a961e66b 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -635,7 +635,8 @@ (when (expand-output) (when source-info-string (fprintf (expand-output) "~%;; expand output for ~a\n" source-info-string)) - (pretty-print ($uncprep x1) (expand-output))) + (pretty-print ($uncprep x1) (expand-output)) + (flush-output-port (expand-output))) (let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()]) (define finish-compile (lambda (x1 f) @@ -683,7 +684,8 @@ [else (sorry! who "unrecognized stuff ~s" x2b)]) (finish x2b))) rx2b*)]) - (pretty-print (if (fx= (length e*) 1) (car e*) `(begin ,@(reverse e*))) (expand/optimize-output)))) + (pretty-print (if (fx= (length e*) 1) (car e*) `(begin ,@(reverse e*))) (expand/optimize-output)) + (flush-output-port (expand/optimize-output)))) ($pass-time 'pfasl (lambda () (c-print-fasl `(group ,@(reverse rfinal*)) op)))) (let ([x1 (car chunk*)]) (cond @@ -1479,7 +1481,8 @@ (let* ([x1 (expand-Lexpand ($pass-time 'expand (lambda () (expand x0 env-spec #t))))] [waste ($uncprep x1 #t)] ; populate preinfo sexpr fields [waste (when (and (expand-output) (not ($noexpand? x0))) - (pretty-print ($uncprep x1) (expand-output)))] + (pretty-print ($uncprep x1) (expand-output)) + (flush-output-port (expand-output)))] [x2 ($pass-time 'cpvalid (lambda () ($cpvalid x1)))] [x2a (let ([cpletrec-ran? #f]) (let ([x ((run-cp0) @@ -1492,7 +1495,8 @@ [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))] [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))]) (when (and (expand/optimize-output) (not ($noexpand? x0))) - (pretty-print ($uncprep x2b) (expand/optimize-output))) + (pretty-print ($uncprep x2b) (expand/optimize-output)) + (flush-output-port (expand/optimize-output))) (if (and (compile-interpret-simple) (not ($assembly-output)) (cheat? x2b)) From 47e236a07cec0b4539e2718afaa678a0963335b2 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Wed, 23 May 2018 15:35:35 -0400 Subject: [PATCH 02/18] clarify "unknown module" error message in determine-module-imports original commit: 6af5ae075c4cce789d3528c3a6ef2620f90793e8 --- LOG | 2 ++ s/syntax.ss | 10 +++++----- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/LOG b/LOG index a4ed4474fd..6b73a069ec 100644 --- a/LOG +++ b/LOG @@ -999,3 +999,5 @@ misc.ms - flush expand-output and expand/optimize-output ports compile.ss +- clarify "unknown module" error message in determine-module-imports + syntax.ss diff --git a/s/syntax.ss b/s/syntax.ss index 119c6e51a7..a20e5c89b6 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -4071,7 +4071,7 @@ ; (and *) ; (or *) ; (not ) - (define (determine-module-imports what mid tid) + (define (determine-module-imports what who mid tid) (let ([binding (lookup (id->label mid empty-wrap) r)]) (case (binding-type binding) [($module) @@ -4087,7 +4087,7 @@ (values mid tid (make-import-interface x (diff-marks (id-marks tid) (interface-marks (get-indirect-interface x))))))] - [else (syntax-error mid "unknown module")]))) + [else (syntax-error who (format "unknown ~a" what))]))) (define (impset x) (syntax-case x () [(?only *x id ...) @@ -4222,13 +4222,13 @@ [else (f (cdr imps) o.n* (cons a new-imps))]))))))))] [mid (and (not std?) (id? #'mid)) - (determine-module-imports "module" #'mid #'mid)] + (determine-module-imports "module" #'mid #'mid #'mid)] [(?library-reference lr) (sym-kwd? ?library-reference library-reference) (let-values ([(mid tid) (lookup-library #'lr)]) - (determine-module-imports "library" mid tid))] + (determine-module-imports "library" #'lr mid tid))] [lr (let-values ([(mid tid) (lookup-library #'lr)]) - (determine-module-imports "library" mid tid))])) + (determine-module-imports "library" #'lr mid tid))])) (syntax-case impspec (for) [(?for *x level ...) (sym-kwd? ?for for) From 8b9b2e6b10b94b6814a816710aa4ac95a468e44d Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Fri, 25 May 2018 11:47:37 -0400 Subject: [PATCH 03/18] restore the import code on reset to provide consistent error message original commit: 3da0f8ed90b849ea4a72d37169fa78652058d70f --- LOG | 2 ++ mats/8.ms | 42 +++++++++++++++++++++++++++++++++++++++++- s/syntax.ss | 9 +++++---- 3 files changed, 48 insertions(+), 5 deletions(-) diff --git a/LOG b/LOG index 6b73a069ec..b783beadb2 100644 --- a/LOG +++ b/LOG @@ -1001,3 +1001,5 @@ compile.ss - clarify "unknown module" error message in determine-module-imports syntax.ss +- restore the import code on reset to provide consistent error message + syntax.ss, 8.ms \ No newline at end of file diff --git a/mats/8.ms b/mats/8.ms index 409086babc..6fa4d6d73f 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -8977,7 +8977,47 @@ (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))]) (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup)))))) "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") -) + + ;; re-arm import code if it complains about a library that is not visible + (begin + (with-output-to-file "testfile-lr-l4.ss" + (lambda () + (pretty-print + '(library (testfile-lr-l4) + (export x) + (import (chezscheme)) + (define x 123)))) + 'replace) + (with-output-to-file "testfile-lr-p4.ss" + (lambda () + (for-each pretty-print + '((import (testfile-lr-l4) (scheme)) + (define (run args) + (guard (c [#t (display-condition c) (newline)]) + (pretty-print (top-level-value (car args) (environment (cdr args)))))) + (when (> x 0) ;; reference export + (let ([args (map string->symbol (command-line-arguments))]) + (if (= (length args) 2) + (begin + (run args) + (run args)) + (error #f "expected 2 args"))))))) + 'replace) + (separate-eval + '(parameterize ([compile-imported-libraries #t] [generate-wpo-files #t]) + (compile-program "testfile-lr-p4.ss") + (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-visible" #t) + (compile-whole-program "testfile-lr-p4.wpo" "testfile-lr-p4-not-visible" #f))) + (equal? + (separate-eval + '(parameterize ([command-line-arguments '("x" "testfile-lr-l4")]) + (load-program "testfile-lr-p4-visible") + (load-program "testfile-lr-p4-not-visible"))) + (string-append + "123\n" + "123\n" + "Exception in visit: library (testfile-lr-l4) is not visible\n" + "Exception in visit: library (testfile-lr-l4) is not visible\n")))) (mat cross-library-optimization (begin diff --git a/s/syntax.ss b/s/syntax.ss index a20e5c89b6..239bb23d67 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -5147,10 +5147,11 @@ (when (eq? p 'loading) ($oops #f "attempt to import library ~s while it is still being loaded" (libdesc-path desc))) (libdesc-import-code-set! desc #f) - (for-each (lambda (req) (import-library (libreq-uid req))) (libdesc-import-req* desc)) - ($install-library-clo-info (libdesc-clo* desc)) - (libdesc-clo*-set! desc '()) - (p))]))] + (on-reset (libdesc-import-code-set! desc p) + (for-each (lambda (req) (import-library (libreq-uid req))) (libdesc-import-req* desc)) + ($install-library-clo-info (libdesc-clo* desc)) + (libdesc-clo*-set! desc '()) + (p)))]))] [else ($oops #f "library ~:s is not defined" uid)]))) ; invoking or visiting a possibly unloaded library occurs in two separate steps: From 36ea9a354de772792ca8c33080ed8ae1f309f1d8 Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Thu, 21 Jun 2018 15:05:06 -0400 Subject: [PATCH 04/18] fix typos original commit: 64a4374513fa19123147c6ef5644f75177a77541 --- csug/syntax.stex | 2 +- csug/system.stex | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/csug/syntax.stex b/csug/syntax.stex index 3a4189eb92..6d29f9ab0c 100644 --- a/csug/syntax.stex +++ b/csug/syntax.stex @@ -1887,7 +1887,7 @@ the annotation is returned. \endentryheader \var{sfd} must be a source-file descriptor. -\var{bfd} must be an exact nonnegative integer and should be the +\var{bfp} must be an exact nonnegative integer and should be the character position of the next character to be read from \var{textual-input-port}. diff --git a/csug/system.stex b/csug/system.stex index d399efcb82..19231adccc 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -3040,7 +3040,7 @@ A \scheme{profile} form has the effect of accounting to the source position identified by \var{source-object} the number of times the \scheme{profile} form is executed. Profile forms are generated implicitly by the expander for source -expressions in annorated input, e.g., input read by the compiler or +expressions in annotated input, e.g., input read by the compiler or interpreter from a Scheme source file, so this form is typically useful only when unannotated source code is produced by the front end for some language that targets Scheme. @@ -3177,7 +3177,7 @@ frequently executed code. This value of this parameter must be a string or \scheme{#f}. If it is a string, the string should contain an HTML cascading style sheet (CSS) color specifier. -If the parameter is set to string, \scheme{profile-dump-html} includes line numbers +If the parameter is set to a string, \scheme{profile-dump-html} includes line numbers in its html rendering of each source file, using the specified color. If the parameter is set to \scheme{#f}, no line numbers are included. @@ -3194,7 +3194,7 @@ This procedure produces a dump of all profile information present in \var{dump}, which defaults to the value returned by \scheme{profile-dump}. It returns a list of entries, each of which is itself a list containing the -following elements identify one block of code and how many times it +following elements identifying one block of code and how many times it has been executed. \begin{itemize} From e57a2a73e3bee79ad44d16ab2144dae3cefa3dc4 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Fri, 31 Aug 2018 09:10:21 -0400 Subject: [PATCH 05/18] added note about git config core.autocrlf in Windows original commit: 1c3a605c6218303f651eec1a8afa5d0bc91337ee --- BUILDING | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/BUILDING b/BUILDING index fb2ff01aee..2ee6d1edda 100644 --- a/BUILDING +++ b/BUILDING @@ -195,10 +195,12 @@ env OS=Windows_NT make Prerequisites: -* Cygwin or Bash/WSL with bash, grep, make, sed, etc. +* Cygwin or Bash/WSL with bash, git, grep, make, sed, etc. * Microsoft Visual Studio 2017 or 2015 * WiX Toolset (for making an install) +Be sure that git config core.autocrlf is set to false. + To run Chez Scheme or Petite Chez Scheme from a Windows command prompt, set PATH: From d468c35f2966936db0ae02ae51e3c8bbf2437ce8 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Fri, 31 Aug 2018 13:22:47 -0400 Subject: [PATCH 06/18] added uninstall target for Unix-like systems original commit: 4e5831fc0220ceede934f1d300b588129f770783 --- BUILDING | 19 +++++++++++++------ LOG | 4 +++- makefiles/Makefile-workarea.in | 3 +++ makefiles/Makefile.in | 3 +++ makefiles/Mf-install.in | 17 ++++++----------- 5 files changed, 28 insertions(+), 18 deletions(-) diff --git a/BUILDING b/BUILDING index 2ee6d1edda..dbfe891d62 100644 --- a/BUILDING +++ b/BUILDING @@ -43,6 +43,10 @@ Prerequisites: * Header files and libraries for ncurses * Header files and libraries for X windows +Uninstalling on Unix-like systems is as simple as running: + +sudo make uninstall + BUILDING VERSION 9.5 AND EARLIER If the environment variable CHEZSCHEMELIBDIRS is set, please unset @@ -129,9 +133,12 @@ The make file supports several targets: is overridden via an argument to ./configure, $W is the same as $M.) 'sudo make install' - runs the build plus installs the resulting executable, boot files, + runs the build plus installs the resulting executables, boot files, example files, and manual pages. +'sudo make uninstall' + uninstalls the executables, boot files, example files, and manual pages. + 'make test' runs the build plus runs a set of test programs in various different ways, e.g., with different compiler options. It can take 30 minutes @@ -185,10 +192,10 @@ The make file supports several targets: WINDOWS Building Chez Scheme under 64-bit Windows with Cygwin or Bash/WSL -follows the instructions above, except that 'make install' is not -supported, and the 'OS' environment variable must be set to -'Windows_NT' on Bash/WSL (to indicate a build for Windows, as opposed -to a build for Linux on Windows): +follows the instructions above, except that 'make install' and 'make +uninstall' are not supported, and the 'OS' environment variable must +be set to 'Windows_NT' on Bash/WSL (to indicate a build for Windows, +as opposed to a build for Linux on Windows): env OS=Windows_NT ./configure env OS=Windows_NT make @@ -223,7 +230,7 @@ make This will create workareas and compile binaries for the a6nt, i3nt, ta6nt, and ti3nt configurations and then include them in a single -Windows installer package Chez Scheme.msi. The package also includes +Windows installer package Chez Scheme.exe. The package also includes example files and the redistributable Microsoft Visual C++ run-time libraries. diff --git a/LOG b/LOG index b783beadb2..1d394897d3 100644 --- a/LOG +++ b/LOG @@ -1002,4 +1002,6 @@ - clarify "unknown module" error message in determine-module-imports syntax.ss - restore the import code on reset to provide consistent error message - syntax.ss, 8.ms \ No newline at end of file + syntax.ss, 8.ms +- add uninstall target + Makefile.in, Makefile-workarea.in, Mf-install.in diff --git a/makefiles/Makefile-workarea.in b/makefiles/Makefile-workarea.in index 4bf89fc2ef..504da9df2b 100644 --- a/makefiles/Makefile-workarea.in +++ b/makefiles/Makefile-workarea.in @@ -23,6 +23,9 @@ build: install: build $(MAKE) -f Mf-install +uninstall: + $(MAKE) -f Mf-install uninstall + test: build (cd mats ; $(MAKE) allx) @echo "test run complete. check $(PREFIX)mats/summary for errors." diff --git a/makefiles/Makefile.in b/makefiles/Makefile.in index 24a6caff47..3e9428999d 100644 --- a/makefiles/Makefile.in +++ b/makefiles/Makefile.in @@ -21,6 +21,9 @@ build: install: (cd $(workarea) && $(MAKE) install) +uninstall: + (cd $(workarea) && $(MAKE) uninstall) + test: (cd $(workarea) && $(MAKE) test PREFIX=$(workarea)/) diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index e0977ef5f2..243060a508 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -79,17 +79,12 @@ SchemeScriptPath=${Bin}/${InstallScriptName} install: bininstall libbininstall maninstall liblibinstall uninstall: - @echo To uninstall all machine types: - @echo rm -rf ${Lib} - @echo rm -f ${PetitePath} - @echo rm -f ${SchemePath} - @echo rm -f ${Man}/${InstallPetiteName}.1'{,.gz}' - @echo rm -f ${Man}/${InstallSchemeName}.1'{,.gz}' - @echo "" - @echo To uninstall just machine-type $m - @echo rm -rf ${Lib}/$m - @echo rm -f ${PetitePath} - @echo rm -f ${SchemePath} + rm -rf ${Lib} + rm -f ${PetitePath} + rm -f ${SchemePath} + rm -f ${SchemeScriptPath} + rm -f ${Man}/${InstallPetiteName}.1{,.gz} + rm -f ${Man}/${InstallSchemeName}.1{,.gz} scheme.1 petite.1: scheme.1.in sed -e "s;{InstallBin};${InstallBin};g" \ From 57b0163e933603f1759af5a79896df3c34d6c87b Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Fri, 7 Sep 2018 16:37:57 -0400 Subject: [PATCH 07/18] add PDB files for Windows original commit: 6d9bda11c1f8d31bf86c559892cf968d7f0c1595 --- LOG | 2 ++ c/Makefile.a6nt | 14 ++++++-------- c/Makefile.i3nt | 11 ++++++----- c/Makefile.ta6nt | 14 ++++++-------- c/Makefile.ti3nt | 11 ++++++----- c/Mf-a6nt | 1 + c/Mf-i3nt | 1 + c/Mf-ta6nt | 1 + c/Mf-ti3nt | 1 + wininstall/a6nt.wxs | 12 ++++++++++++ wininstall/i3nt.wxs | 12 ++++++++++++ wininstall/ta6nt.wxs | 12 ++++++++++++ wininstall/ti3nt.wxs | 12 ++++++++++++ 13 files changed, 78 insertions(+), 26 deletions(-) diff --git a/LOG b/LOG index 1d394897d3..4d6519bffb 100644 --- a/LOG +++ b/LOG @@ -1005,3 +1005,5 @@ syntax.ss, 8.ms - add uninstall target Makefile.in, Makefile-workarea.in, Mf-install.in +- add PDB files for Windows + c/*nt, wininstall/*nt.wxs diff --git a/c/Makefile.a6nt b/c/Makefile.a6nt index 2d3291899d..04c9659e71 100644 --- a/c/Makefile.a6nt +++ b/c/Makefile.a6nt @@ -28,20 +28,18 @@ MDMain = ..\boot\$m\mainmd.obj ResFile = ..\boot\$m\scheme.res # We use MD so that we can link with and load DLLs built against msvcrxxx.dll -CFLAGS=/nologo /Ox /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS MDCFLAGS=$(CFLAGS) /MD MTCFLAGS=$(CFLAGS) /MT -DLLLDFLAGS=/machine:X64 /release /nologo +DLLLDFLAGS=/debug:full /machine:X64 /nologo # stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which # builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB. -EXELDFLAGS=/machine:X64 /incremental:no /release /nologo /STACK:0x1000000 +EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000 # use following flags for debugging -# CFLAGS=/nologo /Od /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS -# MDCFLAGS=$(CFLAGS) /Zi /MDd -# MTCFLAGS=$(CFLAGS) /Zi /MTd -# DLLLDFLAGS=/machine:X64 /debug /nologo /nodefaultlib:msvcrt -# EXELDFLAGS=/machine:X64 /incremental:no /debug /nologo /STACK:0x1000000 +# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib MDZlibLib=..\zlib\zlib.lib diff --git a/c/Makefile.i3nt b/c/Makefile.i3nt index f69173c405..279558721e 100644 --- a/c/Makefile.i3nt +++ b/c/Makefile.i3nt @@ -28,16 +28,17 @@ MDMain = ..\boot\$m\mainmd.obj ResFile = ..\boot\$m\scheme.res # We use MD so that we can link with and load DLLs built against msvcrxxx.dll -CFLAGS=/nologo /fp:precise /Ox /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS MDCFLAGS=$(CFLAGS) /MD MTCFLAGS=$(CFLAGS) /MT -DLLLDFLAGS=/machine:ix86 /release /nologo +DLLLDFLAGS=/debug:full /machine:ix86 /nologo # see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent. -EXELDFLAGS=/machine:ix86 /incremental:no /release /nologo /STACK:0x800000 +EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000 # use following flags for debugging -# CFLAGS=/nologo /Od /W3 /MDd /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DNO_UNISTD_H -# LDFLAGS=/machine:ix86 /incremental:no /release /nologo /debug +# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib MDZlibLib=..\zlib\zlib.lib diff --git a/c/Makefile.ta6nt b/c/Makefile.ta6nt index f2fcb8d2c0..637f1b4889 100644 --- a/c/Makefile.ta6nt +++ b/c/Makefile.ta6nt @@ -28,20 +28,18 @@ MDMain = ..\boot\$m\mainmd.obj ResFile = ..\boot\$m\scheme.res # We use MD so that we can link with and load DLLs built against msvcrxxx.dll -CFLAGS=/nologo /Ox /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS MDCFLAGS=$(CFLAGS) /MD MTCFLAGS=$(CFLAGS) /MT -DLLLDFLAGS=/machine:X64 /release /nologo +DLLLDFLAGS=/debug:full /machine:X64 /nologo # stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which # builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB. -EXELDFLAGS=/machine:X64 /incremental:no /release /nologo /STACK:0x1000000 +EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000 # use following flags for debugging -# CFLAGS=/nologo /Od /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS -# MDCFLAGS=$(CFLAGS) /Zi /MDd -# MTCFLAGS=$(CFLAGS) /Zi /MTd -# DLLLDFLAGS=/machine:X64 /debug /nologo /nodefaultlib:msvcrt -# EXELDFLAGS=/machine:X64 /incremental:no /debug /nologo /STACK:0x1000000 +# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib MDZlibLib=..\zlib\zlib.lib diff --git a/c/Makefile.ti3nt b/c/Makefile.ti3nt index f386e36d22..8dfa80e6fa 100644 --- a/c/Makefile.ti3nt +++ b/c/Makefile.ti3nt @@ -28,16 +28,17 @@ MDMain = ..\boot\$m\mainmd.obj ResFile = ..\boot\$m\scheme.res # We use MD so that we can link with and load DLLs built against msvcrxxx.dll -CFLAGS=/nologo /fp:precise /Ox /W3 /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS MDCFLAGS=$(CFLAGS) /MD MTCFLAGS=$(CFLAGS) /MT -DLLLDFLAGS=/machine:ix86 /release /nologo +DLLLDFLAGS=/debug:full /machine:ix86 /nologo # see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent. -EXELDFLAGS=/machine:ix86 /incremental:no /release /nologo /STACK:0x800000 +EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000 # use following flags for debugging -# CFLAGS=/nologo /Od /W3 /MDd /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DNO_UNISTD_H -# LDFLAGS=/machine:ix86 /incremental:no /release /nologo /debug +# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /DUSE_ANSI_PROTOTYPES /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS +# MDCFLAGS=$(CFLAGS) /MDd +# MTCFLAGS=$(CFLAGS) /MTd SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib MDZlibLib=..\zlib\zlib.lib diff --git a/c/Mf-a6nt b/c/Mf-a6nt index 71898b46e2..a38cc91f58 100644 --- a/c/Mf-a6nt +++ b/c/Mf-a6nt @@ -27,6 +27,7 @@ include Mf-base ${Scheme}: make.bat cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb make.bat: vs.bat echo '@echo off' > $@ diff --git a/c/Mf-i3nt b/c/Mf-i3nt index 855721aa9d..9b37d41d47 100644 --- a/c/Mf-i3nt +++ b/c/Mf-i3nt @@ -27,6 +27,7 @@ include Mf-base ${Scheme}: make.bat cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb make.bat: vs.bat echo '@echo off' > $@ diff --git a/c/Mf-ta6nt b/c/Mf-ta6nt index a6e0d94369..5df2d40d0b 100644 --- a/c/Mf-ta6nt +++ b/c/Mf-ta6nt @@ -27,6 +27,7 @@ include Mf-base ${Scheme}: make.bat cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb make.bat: vs.bat echo '@echo off' > $@ diff --git a/c/Mf-ti3nt b/c/Mf-ti3nt index 5503422757..303b0c09ab 100644 --- a/c/Mf-ti3nt +++ b/c/Mf-ti3nt @@ -27,6 +27,7 @@ include Mf-base ${Scheme}: make.bat cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe + cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb make.bat: vs.bat echo '@echo off' > $@ diff --git a/wininstall/a6nt.wxs b/wininstall/a6nt.wxs index d511ffe1d6..221693e0a6 100755 --- a/wininstall/a6nt.wxs +++ b/wininstall/a6nt.wxs @@ -12,9 +12,15 @@ + + + + + + + + + @@ -60,8 +69,11 @@ + + + diff --git a/wininstall/i3nt.wxs b/wininstall/i3nt.wxs index a4ede0c6af..bc63d1a740 100755 --- a/wininstall/i3nt.wxs +++ b/wininstall/i3nt.wxs @@ -12,9 +12,15 @@ + + + + + + + + + @@ -60,8 +69,11 @@ + + + diff --git a/wininstall/ta6nt.wxs b/wininstall/ta6nt.wxs index ba4f9dc67c..bc65071096 100755 --- a/wininstall/ta6nt.wxs +++ b/wininstall/ta6nt.wxs @@ -12,9 +12,15 @@ + + + + + + + + + @@ -60,8 +69,11 @@ + + + diff --git a/wininstall/ti3nt.wxs b/wininstall/ti3nt.wxs index ef7766a8ec..3ca3ede5f0 100755 --- a/wininstall/ti3nt.wxs +++ b/wininstall/ti3nt.wxs @@ -12,9 +12,15 @@ + + + + + + + + + @@ -62,8 +71,11 @@ + + + From 59c055d91feca99b5423ec2712084aafa0b4e6aa Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Mon, 17 Sep 2018 09:25:11 -0400 Subject: [PATCH 08/18] add note about build directory under Bash/WSL original commit: 41eca9aeea5d036877d09f996414c1f9311ecdb8 --- BUILDING | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/BUILDING b/BUILDING index dbfe891d62..5726e343a0 100644 --- a/BUILDING +++ b/BUILDING @@ -193,9 +193,10 @@ WINDOWS Building Chez Scheme under 64-bit Windows with Cygwin or Bash/WSL follows the instructions above, except that 'make install' and 'make -uninstall' are not supported, and the 'OS' environment variable must -be set to 'Windows_NT' on Bash/WSL (to indicate a build for Windows, -as opposed to a build for Linux on Windows): +uninstall' are not supported. On Bash/WSL, the build directory must be +in a location with a Windows path such as /mnt/c, and the 'OS' +environment variable must be set to 'Windows_NT' to indicate a build +for Windows, as opposed to a build for Linux on Windows: env OS=Windows_NT ./configure env OS=Windows_NT make From 75a70547f8c07e7ab771145f14f2d0dc4821ead9 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Tue, 18 Sep 2018 16:42:51 -0400 Subject: [PATCH 09/18] use uuid_generate on unix-like systems for S_unique_id original commit: 2fd3db68230d094a0d396348a8140a4d3693b120 --- .travis.yml | 2 + .travis/dobuild.sh | 5 ++- BUILDING | 1 + LOG | 2 + c/Mf-a6le | 2 +- c/Mf-arm32le | 2 +- c/Mf-i3le | 2 +- c/Mf-ppc32le | 2 +- c/Mf-ta6le | 2 +- c/Mf-ti3le | 2 +- c/Mf-tppc32le | 2 +- c/stats.c | 66 ++++++++++---------------------- csug/objects.stex | 6 +-- release_notes/release_notes.stex | 6 +++ 14 files changed, 45 insertions(+), 57 deletions(-) diff --git a/.travis.yml b/.travis.yml index ff99c30e55..8b2af94730 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,8 +11,10 @@ matrix: env: TARGET_MACHINE=ta6osx - os: linux env: TARGET_MACHINE=i3le + sudo: required - os: linux env: TARGET_MACHINE=ti3le + sudo: required - os: linux env: TARGET_MACHINE=a6le - os: linux diff --git a/.travis/dobuild.sh b/.travis/dobuild.sh index 066ab1611e..569e219f12 100755 --- a/.travis/dobuild.sh +++ b/.travis/dobuild.sh @@ -1,5 +1,8 @@ #!/bin/bash - +case $TARGET_MACHINE in + *i3le) sudo apt-get -yq --no-install-suggests --no-install-recommends install uuid-dev:i386 ;; + *) +esac ./configure -m=$TARGET_MACHINE exitcode=$? if [ $exitcode -ne 0 ] ; then diff --git a/BUILDING b/BUILDING index 5726e343a0..4a8e5294f9 100644 --- a/BUILDING +++ b/BUILDING @@ -42,6 +42,7 @@ Prerequisites: * gcc * Header files and libraries for ncurses * Header files and libraries for X windows +* Header files and libraries for uuid Uninstalling on Unix-like systems is as simple as running: diff --git a/LOG b/LOG index 4d6519bffb..43b282d86c 100644 --- a/LOG +++ b/LOG @@ -1007,3 +1007,5 @@ Makefile.in, Makefile-workarea.in, Mf-install.in - add PDB files for Windows c/*nt, wininstall/*nt.wxs +- use uuid_generate on unix-like systems for S_unique_id + BUILDING, c/Mf-*le, stats.c, objects.stex, release_notes.stex diff --git a/c/Mf-a6le b/c/Mf-a6le index c6b9b93389..49b8d046c7 100644 --- a/c/Mf-a6le +++ b/c/Mf-a6le @@ -16,7 +16,7 @@ m = a6le Cpu = X86_64 -mdclib = -lm -ldl -lncurses -lrt +mdclib = -lm -ldl -lncurses -lrt -luuid C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} o = o mdsrc = i3le.c diff --git a/c/Mf-arm32le b/c/Mf-arm32le index c4564a5264..a5bb283283 100644 --- a/c/Mf-arm32le +++ b/c/Mf-arm32le @@ -16,7 +16,7 @@ m = arm32le Cpu = ARMV6 -mdclib = -lm -ldl -lncurses -lrt +mdclib = -lm -ldl -lncurses -lrt -luuid C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} o = o mdsrc = arm32le.c diff --git a/c/Mf-i3le b/c/Mf-i3le index 9d3b30db49..e9cf27d766 100644 --- a/c/Mf-i3le +++ b/c/Mf-i3le @@ -16,7 +16,7 @@ m = i3le Cpu = I386 -mdclib = -lm -ldl -lncurses -lrt +mdclib = -lm -ldl -lncurses -lrt -luuid C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -fno-stack-protector ${CFLAGS} o = o mdsrc = i3le.c diff --git a/c/Mf-ppc32le b/c/Mf-ppc32le index bf209fb233..844be15128 100644 --- a/c/Mf-ppc32le +++ b/c/Mf-ppc32le @@ -16,7 +16,7 @@ m = ppc32le Cpu = PPC32 -mdclib = -lm -ldl -lncurses -lrt +mdclib = -lm -ldl -lncurses -lrt -luuid C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} o = o mdsrc = ppc32.c diff --git a/c/Mf-ta6le b/c/Mf-ta6le index 206afc5070..30cc11d629 100644 --- a/c/Mf-ta6le +++ b/c/Mf-ta6le @@ -16,7 +16,7 @@ m = ta6le Cpu = X86_64 -mdclib = -lm -ldl -lncurses -lpthread -lrt +mdclib = -lm -ldl -lncurses -lpthread -lrt -luuid C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} o = o mdsrc = i3le.c diff --git a/c/Mf-ti3le b/c/Mf-ti3le index 388360282b..dad6af7c91 100644 --- a/c/Mf-ti3le +++ b/c/Mf-ti3le @@ -16,7 +16,7 @@ m = ti3le Cpu = I386 -mdclib = -lm -ldl -lncurses -lpthread -lrt +mdclib = -lm -ldl -lncurses -lpthread -lrt -luuid C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} o = o mdsrc = i3le.c diff --git a/c/Mf-tppc32le b/c/Mf-tppc32le index c888664fe1..a1a66d97e1 100644 --- a/c/Mf-tppc32le +++ b/c/Mf-tppc32le @@ -16,7 +16,7 @@ m = tppc32le Cpu = PPC32 -mdclib = -lm -ldl -lncurses -lpthread -lrt +mdclib = -lm -ldl -lncurses -lpthread -lrt -luuid C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} o = o mdsrc = ppc32le.c diff --git a/c/stats.c b/c/stats.c index 4e3ee139b0..ae5640a0df 100644 --- a/c/stats.c +++ b/c/stats.c @@ -53,57 +53,33 @@ static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff); #include ptr S_unique_id() { - union {UUID uuid; INT foo[4];} u; - u.foo[0] = 0; - u.foo[1] = 0; - u.foo[2] = 0; - u.foo[3] = 0; - - UuidCreate(&u.uuid); - return S_add(S_ash(Sunsigned(u.foo[0]), Sinteger(8*3*sizeof(INT))), - S_add(S_ash(Sunsigned(u.foo[1]), Sinteger(8*2*sizeof(INT))), - S_add(S_ash(Sunsigned(u.foo[2]), Sinteger(8*sizeof(INT))), - Sunsigned(u.foo[3])))); + union {UUID uuid; U32 foo[4];} u; + u.foo[0] = 0; + u.foo[1] = 0; + u.foo[2] = 0; + u.foo[3] = 0; + UuidCreate(&u.uuid); + return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))), + Sunsigned32(u.foo[3])))); } #else /* WIN32 */ -#include -#include -#include -#include -#include - -static INT gethostip(void) { - char hostname[MAXHOSTNAMELEN+1]; - struct hostent *h; - char **p; - struct in_addr in; - - if (gethostname(hostname, MAXHOSTNAMELEN)) return 0; - if ((h = gethostbyname(hostname)) == NULL) return 0; - p = h->h_addr_list; - if (*p == NULL) return 0; - - memcpy(&in.s_addr, *p, sizeof (in.s_addr)); - return in.s_addr; -} +#include ptr S_unique_id() { - struct timeval tp; - time_t sec; - pid_t pid; - INT ip; - - (void) gettimeofday(&tp,NULL); - - pid = getpid(); - ip = gethostip(); - sec = tp.tv_sec; - - return S_add(S_ash(Sunsigned(pid), Sinteger(8*(sizeof(sec)+sizeof(ip)))), - S_add(S_ash(Sunsigned(ip), Sinteger(8*(sizeof(sec)))), - Sunsigned(sec))); + union {uuid_t uuid; U32 foo[4];} u; + u.foo[0] = 0; + u.foo[1] = 0; + u.foo[2] = 0; + u.foo[3] = 0; + uuid_generate(u.uuid); + return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))), + S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))), + Sunsigned32(u.foo[3])))); } #endif /* WIN32 */ diff --git a/csug/objects.stex b/csug/objects.stex index a40e855512..ec65e46304 100644 --- a/csug/objects.stex +++ b/csug/objects.stex @@ -1418,10 +1418,8 @@ The pretty name of a gensym is returned by the procedure In both the first and second forms, the unique name is an automatically generated globally unique name. -Globally unique names are constructed (lazily---see below) -from some combination of a unique machine identifier (such as the -network address), the current process identifier (PID), and the -time at which the Scheme session began, along with an internal +Globally unique names are constructed (lazily---see below) from the +combination of a universally unique identifier and an internal counter. In the third form of gensym, the unique name of the new gensym is \var{unique-name}, which must be a string. diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 0ad6eac72d..7f93595c35 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1592,6 +1592,12 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Globally unique names on non-Windows systems no longer contain the IP address (9.5.1)} + +The globally unique names of gensyms no longer contain the IP address +on non-Windows systems. Windows systems already used a universally +unique identifier. + \subsection{Invalid memory reference from \protect\scheme{fxvector} calls (9.5)} A compiler bug that could result in an invalid memory reference or From 19f3c85fe2570e6c783e111d095bb799bb22fd57 Mon Sep 17 00:00:00 2001 From: dyb Date: Fri, 5 Oct 2018 09:03:30 -0700 Subject: [PATCH 10/18] attempted partial fix for github issue 352 - when thread_get_room exhausts the local allocation area, it now goes through a common path with S_get_more_room to allocate a new local allocation area when appropriate. this can greatly reduce the use of global allocation (and the number of tc mutex acquires in threaded builds) when a lot of small objects are allocated by C code with no intervening Scheme-side allocation or dirty writes. alloc.c, types.h, externs.h original commit: 93dfa7674a95837e5a22bc622fecc50b0224f60d --- LOG | 7 +++++++ c/alloc.c | 41 ++++++++++++++++++++--------------------- c/externs.h | 2 +- c/types.h | 2 +- 4 files changed, 29 insertions(+), 23 deletions(-) diff --git a/LOG b/LOG index 43b282d86c..a8a2ecdf60 100644 --- a/LOG +++ b/LOG @@ -1009,3 +1009,10 @@ c/*nt, wininstall/*nt.wxs - use uuid_generate on unix-like systems for S_unique_id BUILDING, c/Mf-*le, stats.c, objects.stex, release_notes.stex +- when thread_get_room exhausts the local allocation area, it now + goes through a common path with S_get_more_room to allocate a new + local allocation area when appropriate. this can greatly reduce + the use of global allocation (and the number of tc mutex acquires + in threaded builds) when a lot of small objects are allocated by + C code with no intervening Scheme-side allocation or dirty writes. + alloc.c, types.h, externs.h diff --git a/c/alloc.c b/c/alloc.c index 84da3678ad..efdd268969 100644 --- a/c/alloc.c +++ b/c/alloc.c @@ -150,14 +150,6 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; { return Sunsigned(n); } -ptr S_thread_get_more_room(t, n) iptr t; iptr n; { - ptr x; - tc_mutex_acquire() - find_room(space_new, 0, t, n, x); - tc_mutex_release() - return x; -} - static void maybe_fire_collector() { ISPC s; uptr bytes, fudge; @@ -369,24 +361,29 @@ void S_scan_remembered_set() { void S_get_more_room() { ptr tc = get_thread_context(); - ptr xp; uptr ap, eap, real_eap, type, size; - - tc_mutex_acquire() - - ap = (uptr)AP(tc); - eap = (uptr)EAP(tc); - real_eap = (uptr)REAL_EAP(tc); + ptr xp; uptr ap, type, size; xp = XP(tc); if ((type = TYPEBITS(xp)) == 0) type = typemod; - size = ap - (iptr)UNTYPE(xp,type); - ap -= size; + ap = (uptr)UNTYPE(xp, type); + size = (uptr)((iptr)AP(tc) - (iptr)ap); + + XP(tc) = S_get_more_room_help(tc, ap, type, size); +} + +ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) { + ptr x; uptr eap, real_eap; + + eap = (uptr)EAP(tc); + real_eap = (uptr)REAL_EAP(tc); + + tc_mutex_acquire() S_scan_dirty((ptr **)eap, (ptr **)real_eap); eap = real_eap; if (eap - ap >= size) { - XP(tc) = TYPE(ap, type); + x = TYPE(ap, type); ap += size; if (eap - ap > alloc_waste_maximum) { AP(tc) = (ptr)ap; @@ -398,20 +395,22 @@ void S_get_more_room() { } else if (eap - ap > alloc_waste_maximum) { AP(tc) = (ptr)ap; EAP(tc) = (ptr)eap; - find_room(space_new, 0, type, size, XP(tc)); + find_room(space_new, 0, type, size, x); } else { S_G.bytes_of_space[space_new][0] -= eap - ap; S_reset_allocation_pointer(tc); ap = (uptr)AP(tc); if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) { - XP(tc) = TYPE(ap, type); + x = TYPE(ap, type); AP(tc) = (ptr)(ap + size); } else { - find_room(space_new, 0, type, size, XP(tc)); + find_room(space_new, 0, type, size, x); } } tc_mutex_release() + + return x; } /* S_cons_in is always called with mutex */ diff --git a/c/externs.h b/c/externs.h index 692712e357..778db3b85b 100644 --- a/c/externs.h +++ b/c/externs.h @@ -59,6 +59,7 @@ extern void S_dirty_set PROTO((ptr *loc, ptr x)); extern void S_scan_dirty PROTO((ptr **p, ptr **endp)); extern void S_scan_remembered_set PROTO((void)); extern void S_get_more_room PROTO((void)); +extern ptr S_get_more_room_help PROTO((ptr tc, uptr ap, uptr type, uptr size)); extern ptr S_cons_in PROTO((ISPC s, IGEN g, ptr car, ptr cdr)); extern ptr S_symbol PROTO((ptr name)); extern ptr S_rational PROTO((ptr n, ptr d)); @@ -88,7 +89,6 @@ extern ptr S_string PROTO((const char *s, iptr n)); extern ptr S_bignum PROTO((iptr n, IBOOL sign)); extern ptr S_code PROTO((ptr tc, iptr type, iptr n)); extern ptr S_relocation_table PROTO((iptr n)); -extern ptr S_thread_get_more_room PROTO((iptr t, iptr n)); /* fasl.c */ extern void S_fasl_init PROTO((void)); diff --git a/c/types.h b/c/types.h index ca4e582070..872dc17671 100644 --- a/c/types.h +++ b/c/types.h @@ -96,7 +96,7 @@ typedef int IFASLCODE; /* fasl type codes */ ptr _tc = tc;\ uptr _ap = (uptr)AP(_tc);\ if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\ - (x) = S_thread_get_more_room(t, n);\ + (x) = S_get_more_room_help(_tc, _ap, t, n);\ } else {\ (x) = TYPE(_ap,t);\ AP(_tc) = (ptr)(_ap + n);\ From 03ae461f54797fa32adf4c3b05fe69622e58940a Mon Sep 17 00:00:00 2001 From: "Matthew D. Miller" Date: Fri, 5 Oct 2018 14:53:02 -0500 Subject: [PATCH 11/18] Fixes typos pointed out in #353 original commit: ebee5db8fac9639bd88f313ef0c4a0641dba8317 --- csug/binding.stex | 10 +++++----- csug/io.stex | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/csug/binding.stex b/csug/binding.stex index 8152937940..6150d64059 100644 --- a/csug/binding.stex +++ b/csug/binding.stex @@ -49,7 +49,7 @@ albeit scoped where the bindings of the \scheme{let-syntax} or in a library or RNRS top-level program unless the \scheme{scheme} library is included in the library or top-level programs imports. -These forms are described in Chatper~\ref{CHPTSYNTAX}. +These forms are described in Chapter~\ref{CHPTSYNTAX}. In Revised$^6$ Report Scheme, definitions can appear at the front of a \scheme{lambda} or similar body (e.g., a \scheme{let} or \scheme{letrec} @@ -66,8 +66,8 @@ procedure. The macro expander uses the same two-pass algorithm for expanding top-level \scheme{begin} expressions as it uses for a \scheme{lambda}, \scheme{library}, or top-level program body. -(This algorithm is described in Section~\ref{SECTSYNTAXDEFINITIONS} of {\TSPLFOUR}.) -As a result, +(This algorithm is described in Section~\ref{TSPL:SECTSYNTAXDEFINITIONS} of +{\TSPLFOUR}.) As a result, \schemedisplay (begin @@ -85,7 +85,7 @@ and both result in the giving \scheme{x} the value 3, even though an unbound variable reference to \scheme{a} would result if -the two forms within the latter \scheme{begin} expression where run +the two forms within the latter \scheme{begin} expression were run independently at top level. Similarly, the \scheme{begin} form produced by a use of @@ -136,7 +136,7 @@ for internal variable definitions, for backward compatibility. %---------------------------------------------------------------------------- \noskipentryheader -\formdef{define-values}{\categorysyntax}{(define-values formals \var{expr})} +\formdef{define-values}{\categorysyntax}{(define-values \var{formals} \var{expr})} \listlibraries \endnoskipentryheader diff --git a/csug/io.stex b/csug/io.stex index f0d9c4400e..c8a15792ce 100644 --- a/csug/io.stex +++ b/csug/io.stex @@ -310,7 +310,7 @@ predicate \scheme{transcoder?}, which should be standard but is not. \scheme{little}. The codec returned by \scheme{utf-16-codec} can be used to create -process data written UFT-16 format. +process data written UTF-16 format. When called without the \var{endianness} argument or with \var{endianness} \scheme{big}, \scheme{utf-16-codec} returns a codec for standard UTF-16 data, i.e., one that defaults to big-endian format if no byte-order mark From 4699fc1db09eebbca9f9ce774a35656d1be37ace Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Mon, 22 Oct 2018 15:41:30 -0400 Subject: [PATCH 12/18] improved consistency of Windows filename handling original commit: 9017943cdba8c54c8f0acf20b037174780c10039 --- LOG | 5 +++ csug/io.stex | 4 +- mats/6.ms | 42 ++++++++++----------- release_notes/release_notes.stex | 14 +++++++ s/6.ss | 65 ++++++-------------------------- 5 files changed, 53 insertions(+), 77 deletions(-) diff --git a/LOG b/LOG index a8a2ecdf60..52c55e60c0 100644 --- a/LOG +++ b/LOG @@ -1016,3 +1016,8 @@ in threaded builds) when a lot of small objects are allocated by C code with no intervening Scheme-side allocation or dirty writes. alloc.c, types.h, externs.h +- made Windows filename handling in directory-list, file-access-time, + file-change-time, file-directory?, file-exists?, file-modification-time, + get-mode, and path-absolute more consistent with + https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file + 6.ss, 6.ms, io.stex, release_notes.stex diff --git a/csug/io.stex b/csug/io.stex index f0d9c4400e..7eac9096a8 100644 --- a/csug/io.stex +++ b/csug/io.stex @@ -3687,9 +3687,9 @@ are involved. \begin{tabular}{llllllll} path & abs & first & rest & parent & last & root & ext \\ -\scheme{c:} & \scheme{#t} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} \\ +\scheme{c:} & \scheme{#f} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} & \scheme{c:} & \scheme{_} \\ \scheme{c:/} & \scheme{#t} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} & \scheme{c:/} & \scheme{_} \\ -\scheme{c:a/b} & \scheme{#t} & \scheme{c:} & \scheme{a/b} & \scheme{c:a} & \scheme{b} & \scheme{c:a/b} & \scheme{_} \\ +\scheme{c:a/b} & \scheme{#f} & \scheme{c:} & \scheme{a/b} & \scheme{c:a} & \scheme{b} & \scheme{c:a/b} & \scheme{_} \\ \scheme{//s/a/b.c} & \scheme{#t} & \scheme{//s} & \scheme{a/b.c} & \scheme{//s/a} & \scheme{b.c} & \scheme{//s/a/b} & \scheme{c} \\ \scheme{//s.com} & \scheme{#t} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} & \scheme{//s.com} & \scheme{_} \\ \end{tabular} diff --git a/mats/6.ms b/mats/6.ms index f47e6239f3..667ecb6b4d 100644 --- a/mats/6.ms +++ b/mats/6.ms @@ -1673,7 +1673,7 @@ (begin (define-record $acyclic ((immutable notme))) (record-reader '$acyclic (type-descriptor $acyclic))) (xmat - "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@5.9babcd\f&\n" + "; Test error \"fasl object created by different release\"\n; This one is the list (a b c d) created by version 5.9b\n\n#@\x2;\x4;\x0;\x0;\x0;5.9b\x0;\x4;\x0;\x0;\x0;\x2;\x1;\x0;\x0;\x0;a\x2;\x1;\x0;\x0;\x0;b\x2;\x1;\x0;\x0;\x0;c\x2;\x1;\x0;\x0;\x0;d\f&\x0;\x0;\x0;\n" ) (xmat @@ -2858,7 +2858,7 @@ (or (not (windows?)) (> (length (directory-list "\\\\?\\c:\\")) 0)) (or (not (windows?)) - (> (length (directory-list "\\\\?\\c:")) 0)) + (> (length (directory-list "\\\\?\\C:\\")) 0)) (file-directory? "/") (file-directory? "/.") (file-exists? ".") @@ -2869,7 +2869,7 @@ (file-directory? "c:/.")) (not (file-directory? "c:"))) (if (windows?) - (and (file-directory? "\\\\?\\c:") + (and (not (file-directory? "\\\\?\\c:")) (file-directory? "\\\\?\\c:\\")) (not (file-directory? "\\\\?\\c:"))) (if (windows?) @@ -2878,7 +2878,7 @@ (file-exists? "c:/.")) (not (file-exists? "c:"))) (if (windows?) - (and (file-exists? "\\\\?\\c:") + (and (not (file-exists? "\\\\?\\c:")) (file-exists? "\\\\?\\c:\\")) (not (file-exists? "\\\\?\\c:"))) (if (windows?) @@ -2899,9 +2899,9 @@ (and (logtest m #o400) (not (logtest m #o111))))) (or (not (windows?)) - (and (fixnum? (get-mode "c:")) - (eqv? (get-mode "c:") (get-mode "c:/")) - (eqv? (get-mode "c:") (get-mode "c:/.")))) + (and (fixnum? (get-mode "c:/")) + (eqv? (get-mode "c:/") (get-mode "C:\\")) + (eqv? (get-mode "c:/") (get-mode "c:\\.")))) (if (or (windows?) (embedded?)) (fixnum? (get-mode "../mats")) (eqv? (logand (get-mode "../mats") #o700) #o700)) @@ -2930,9 +2930,9 @@ (time? (file-change-time "c:/")) (time? (file-modification-time "c:/")))) (or (not (windows?)) - (and (time? (file-access-time "\\\\?\\c:")) - (time? (file-change-time "\\\\?\\c:")) - (time? (file-modification-time "\\\\?\\c:")))) + (and (time? (file-access-time "\\\\?\\C:\\")) + (time? (file-change-time "\\\\?\\C:\\")) + (time? (file-modification-time "\\\\?\\C:\\")))) (or (not (windows?)) (and (time? (file-access-time "\\\\?\\c:\\")) (time? (file-change-time "\\\\?\\c:\\")) @@ -3120,9 +3120,7 @@ (eq? (path-absolute? "/abc") #t) (eq? (path-absolute? "foo") #f) (eq? (path-absolute? "foo/bar/a.b") #f) - (eq? - (path-absolute? "c:abc") - (and (windows?) #t)) + (eq? (path-absolute? "c:abc") #f) (equal? (path-parent "") "") (equal? (path-parent "a") "") @@ -3275,17 +3273,17 @@ ; windows (if (windows?) (table - ("c:" "t" "c:" "" "c:" "" "c:" "") + ("c:" "f" "c:" "" "c:" "" "c:" "") ("c:/" "t" "c:/" "" "c:/" "" "c:/" "") - ("c:.." "t" "c:" ".." "c:" ".." "c:.." "") - ("c:../" "t" "c:" "../" "c:.." "" "c:../" "") - ("c:../a" "t" "c:" "../a" "c:.." "a" "c:../a" "") - ("c:." "t" "c:" "." "c:" "." "c:." "") - ("c:./" "t" "c:" "./" "c:." "" "c:./" "") - ("c:./a" "t" "c:" "./a" "c:." "a" "c:./a" "") + ("c:.." "f" "c:" ".." "c:" ".." "c:.." "") + ("c:../" "f" "c:" "../" "c:.." "" "c:../" "") + ("c:../a" "f" "c:" "../a" "c:.." "a" "c:../a" "") + ("c:." "f" "c:" "." "c:" "." "c:." "") + ("c:./" "f" "c:" "./" "c:." "" "c:./" "") + ("c:./a" "f" "c:" "./a" "c:." "a" "c:./a" "") ("c:/abc" "t" "c:/" "abc" "c:/" "abc" "c:/abc" "") - ("c:abc" "t" "c:" "abc" "c:" "abc" "c:abc" "") - ("c:abc/def" "t" "c:" "abc/def" "c:abc" "def" "c:abc/def" "") + ("c:abc" "f" "c:" "abc" "c:" "abc" "c:abc" "") + ("c:abc/def" "f" "c:" "abc/def" "c:abc" "def" "c:abc/def" "") ("c:/abc/def" "t" "c:/" "abc/def" "c:/abc" "def" "c:/abc/def" "") ("//abc" "t" "//abc" "" "//abc" "" "//abc" "") ("//abc/" "t" "//abc" "" "//abc" "" "//abc/" "") diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 7f93595c35..289d6d1eb5 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1592,6 +1592,20 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Disk-relative filenames in Windows (9.5.1)} + +In Windows, filenames that start with a disk designator but no +directory separator are now treated as relative paths. For example, +\scheme{(path-absolute? "C:")} now returns \scheme{#f}, and +\scheme{(directory-list "C:")} now lists the files in the current +directory on disk C instead of the files in the root directory of disk +C. + +In addition, \scheme{file-access-time}, \scheme{file-change-time}, +\scheme{file-directory?}, \scheme{file-exists?}, +\scheme{file-modification-time}, and \scheme{get-mode} no longer +remove trailing directory separators on Windows. + \subsection{Globally unique names on non-Windows systems no longer contain the IP address (9.5.1)} The globally unique names of gensyms no longer contain the IP address diff --git a/s/6.ss b/s/6.ss index 76da9a8227..14adf00cd5 100644 --- a/s/6.ss +++ b/s/6.ss @@ -128,15 +128,7 @@ (let ([x (fp path follow?)]) (if (fixnum? x) x - (if-feature windows - (let ([y (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))]) - (if (fixnum? y) y (err x))) - (err x))))])))) + (err x)))])))) (let () (define file-x-time @@ -155,18 +147,7 @@ (let ([x (path-fp file follow?)]) (if (pair? x) (make-time 'time-utc (cdr x) (car x)) - (if-feature windows - (let ([y (let ([n (string-length file)]) - (and (fx> n 0) - (path-fp - (if (directory-separator? (string-ref file (fx- n 1))) - (substring file 0 (fx- n 1)) - (string-append file "\\")) - follow?)))]) - (if (pair? y) - (make-time 'time-utc (cdr y) (car y)) - (path-err file x))) - (path-err file x)))) + (path-err file x))) (let ([x (fd-fp (port-file-descriptor file))]) (cond [(pair? x) (make-time 'time-utc (cdr x) (car x))] @@ -208,9 +189,9 @@ (and (not (char=? (string-ref path i) #\*)) (nostars? (fx+ i 1)))))) ($oops who "invalid directory name ~s" path)) - (wl (if (directory-separator? (string-ref path (fx- n 1))) - (format "~a*" path) - (format "~a\\*" path)))))) + (wl (if (memv (string-ref path (fx- n 1)) '(#\\ #\/ #\:)) + (string-append path "*") + (string-append path "\\*")))))) (foreign-procedure "(cs)directory_list" (string) scheme-object))]) (lambda (path) (unless (string? path) ($oops who "~s is not a string" path)) @@ -237,15 +218,7 @@ [(path) (file-exists? path #t)] [(path follow?) (unless (string? path) ($oops who "~s is not a string" path)) - (if-feature windows - (or (fp path follow?) - (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))) - (fp path follow?))])))) + (fp path follow?)])))) (define-who #(r6rs: file-exists?) (lambda (path) @@ -267,15 +240,7 @@ [(path) (file-directory? path #t)] [(path follow?) (unless (string? path) ($oops who "~s is not a string" path)) - (if-feature windows - (or (fp path follow?) - (let ([n (string-length path)]) - (and (fx> n 0) - (fp (if (directory-separator? (string-ref path (fx- n 1))) - (substring path 0 (fx- n 1)) - (string-append path "\\")) - follow?)))) - (fp path follow?))])))) + (fp path follow?)])))) (define-who file-symbolic-link? (let ([fp (foreign-procedure "(cs)file_symbolic_linkp" (string) boolean)]) @@ -376,7 +341,7 @@ (char=? (string-ref s 1) #\:) (let ([c (string-ref s 0)]) (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (if (and (>= n 3) (directory-separator? (string-ref s 2))) 3 2)] + (if (and (fx>= n 3) (directory-separator? (string-ref s 2))) 3 2)] [(and windows? (fx>= n 4) (char=? (string-ref s 0) #\\) @@ -388,7 +353,7 @@ (char=? (string-ref s 5) #\:) (let ([c (string-ref s 4)]) (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (if (and (>= n 7) (char=? (string-ref s 6) #\\)) 7 6)] + (if (and (fx>= n 7) (char=? (string-ref s 6) #\\)) 7 6)] [(and windows? (fx>= n 8) (char-ci=? (string-ref s 4) #\U) @@ -427,22 +392,16 @@ (set-who! path-absolute? (lambda (s) - (define directory-separator? (directory-separator-predicate s)) (unless (string? s) ($oops who "~s is not a string" s)) (let ([n (string-length s)]) (or (and (fx>= n 1) (directory-separator? (string-ref s 0))) (and (fx>= n 1) (char=? (string-ref s 0) #\~)) (and windows? - (fx>= n 2) + (fx>= n 3) (char=? (string-ref s 1) #\:) (let ([c (string-ref s 0)]) - (or (char<=? #\a c #\z) (char<=? #\A c #\Z)))) - (and windows? - (fx>= n 4) - (char=? (string-ref s 0) #\\) - (char=? (string-ref s 1) #\\) - (char=? (string-ref s 2) #\?) - (char=? (string-ref s 3) #\\)))))) + (or (char<=? #\a c #\z) (char<=? #\A c #\Z))) + (directory-separator? (string-ref s 2))))))) (set-who! path-extension (lambda (s) From 530882e379fa92058041ec5ddc170ab21b5cfc5d Mon Sep 17 00:00:00 2001 From: dyb Date: Mon, 22 Oct 2018 19:29:30 -0700 Subject: [PATCH 13/18] addressed small portions of github issues #278 and #353: updated descriptions of standard-input-port and standard-output-port; fixed a missing "and" in the description of utf-16-codec, original commit: a5db479b68b74dda9f62665c44cfad2b1baf322e --- csug/io.stex | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/csug/io.stex b/csug/io.stex index 90c27d7123..0c0bfc1ea4 100644 --- a/csug/io.stex +++ b/csug/io.stex @@ -309,7 +309,7 @@ predicate \scheme{transcoder?}, which should be standard but is not. \var{endianness} must be the symbol \scheme{big} or the symbol \scheme{little}. -The codec returned by \scheme{utf-16-codec} can be used to create +The codec returned by \scheme{utf-16-codec} can be used to create and process data written UTF-16 format. When called without the \var{endianness} argument or with \var{endianness} \scheme{big}, \scheme{utf-16-codec} returns a codec for standard UTF-16 @@ -1359,11 +1359,7 @@ If \var{?transcoder} is present and not \scheme{#f}, it must be a transcoder, and this procedure returns a textual input port whose transcoder is \var{?transcoder}. Otherwise, this procedure returns a binary input port. -The buffer mode \var{b-mode} defaults to \scheme{block}, which differs from -\scheme{block} in {\ChezScheme} only for textual output ports. -See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} -for a description of the constraints on and effects of the other -arguments. +The buffer mode \var{b-mode} defaults to \scheme{block}. The Revised$^6$ Report version of this procedure does not accept the optional \var{b-mode} and \var{?transcoder} arguments, which limits @@ -1985,9 +1981,6 @@ whose transcoder is \var{?transcoder}. Otherwise, this procedure returns a binary output port. The buffer mode \var{b-mode} defaults to \scheme{line}, which differs from \scheme{block} in {\ChezScheme} only for textual output ports. -See the lead-in to Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR} -for a description of the constraints on and effects of the other -arguments. The Revised$^6$ Report version of this procedure does not accept the optional \var{b-mode} and \var{?transcoder} arguments, which limits From 54ffb5dfbe0ea13addb09564566b03036568176a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 16 Nov 2018 10:37:30 -0700 Subject: [PATCH 14/18] reliably preserve cp in thread context for S_call_help Also, for completeness, correct the listing of callee-save registers in callable return for x86 & x86_64. original commit: 4cd942be6ab2eb5e02f6d6c5c509db3131bd015f --- LOG | 4 ++++ mats/foreign.ms | 27 +++++++++++++++++++++++---- mats/foreign2.c | 19 +++++++++++++++++++ s/cpnanopass.ss | 12 ++++++++---- s/x86.ss | 2 ++ s/x86_64.ss | 6 +++++- 6 files changed, 61 insertions(+), 9 deletions(-) diff --git a/LOG b/LOG index 52c55e60c0..7bec4b119f 100644 --- a/LOG +++ b/LOG @@ -1021,3 +1021,7 @@ get-mode, and path-absolute more consistent with https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file 6.ss, 6.ms, io.stex, release_notes.stex +- fix handling of calling code's address for locking around a callable, + where the cp register copy in the thread context could be changed + in the callable prep before S_call_help gets it + cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms diff --git a/mats/foreign.ms b/mats/foreign.ms index 381ec435eb..3b34840cfd 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -2516,6 +2516,29 @@ (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))]) (list v (locked-object? Fcons))))) '((#t #f) (#t #f))) + + ;; Make sure the code pointer for a call into a + ;; foreign procedure is correctly saved for locking + ;; when entering a callback as a callable: + (equal? + (let () + (define v 0) + (define call_many_times (foreign-procedure "call_many_times" (void*) void)) + (define work + (lambda (n) + ;; This loop needs to be non-allocating, but + ;; causes varying numbers of ticks + ;; to be used up. + (let loop ([n (bitwise-and n #xFFFF)]) + (unless (zero? n) + (set! v (add1 v)) + (loop (bitwise-arithmetic-shift-right n 1)))))) + (define handler (foreign-callable work (long) void)) + (lock-object handler) + (call_many_times (foreign-callable-entry-point handler)) + v) + 14995143) + ) (machine-case @@ -3021,10 +3044,6 @@ (let ([m (make-mutex)] [done? #f] [ok? #t]) - (define object->addr - (foreign-procedure "(cs)fxmul" - (scheme-object uptr) - uptr)) (fork-thread (lambda () (let loop ([i 10]) (unless (zero? i) diff --git a/mats/foreign2.c b/mats/foreign2.c index 03b7ea6f95..d69b4898ab 100644 --- a/mats/foreign2.c +++ b/mats/foreign2.c @@ -424,3 +424,22 @@ EXPORT i64 ifoo64a(i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) { EXPORT i64 ifoo64b(i32 x, i64 a, i64 b, i64 c, i64 d, i64 e, i64 f, i64 g) { return (i64)x + (a - b) + (c - d) + (e - f) + g; } + +EXPORT void call_many_times(void (*f)(iptr)) +{ + int x; + iptr a = 1, b = 3, c = 5, d = 7; + iptr e = 1, g = 3, h = 5, i = 7; + iptr j = 1, k = 3, l = 5, m = 7; + iptr big = (((iptr)1) << ((8 * sizeof(iptr)) - 2)); + + /* The intent of the loop is to convince the C compiler to store + something in the same register used for CP (so, compile with + optimization). */ + for (x = 0; x < 1000000; x++) { + f(big|(a+e+j)); + a = b; b = c; c = d; d = e; + e = g; g = h; h = i; i = j; + j = k+2; k = l+2; l = m+2; m = m+2; + } +} diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 19699e1cb1..310054441b 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -10730,9 +10730,12 @@ ; c-return restores callee-save registers and returns to C (%seq ,(c-init) + ; although we don't actually need %cp in a register, we need + ; to make sure that `(%tc-ref cp)` doesn't change before S_call_help + ; is called, and claiming that %cp is live is the easiest way ,(restore-scheme-state - (in) ; save just the required registers, e.g., %sfp - (out %ac0 %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)) + (in %cp) + (out %ac0 %ac1 %xp %yp %ts %td scheme-args extra-regs)) ; need overflow check since we're effectively retroactively turning ; what was a foreign call into a Scheme non-tail call (fcallable-overflow-check) @@ -10748,8 +10751,8 @@ (set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0))) (set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking ,(save-scheme-state - (in %ac0 %ac1 %ts) - (out %cp %xp %yp %td scheme-args extra-regs)) + (in %ac0 %ac1 %ts %cp) + (out %xp %yp %td scheme-args extra-regs)) ; Scall-{any,one}-results calls the Scheme implementation of the ; callable, locking this callable wrapper (as communicated in %ts) ; until just before returning @@ -10757,6 +10760,7 @@ ,(restore-scheme-state (in %ac0) (out %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)) + ; assuming no use of %cp from here on that could get saved into `(%tc-ref cp)`: ,(Scheme->C-for-result result-type c-result %ac0) ,(c-return))))))))))) (define handle-do-rest diff --git a/s/x86.ss b/s/x86.ss index 581b1380aa..d64f9de1da 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -2882,6 +2882,7 @@ locs)) get-result (lambda () + (define callee-save-regs (list %ebx %edi %esi %ebp)) (in-context Tail ((lambda (e) (if adjust-active? @@ -2913,5 +2914,6 @@ ;; after popping the return address (make-info-c-return 4) null-info) + ,callee-save-regs ... ,result-regs ...))))))))))))))) ) diff --git a/s/x86_64.ss b/s/x86_64.ss index 82ca94d9fe..f769f1a6fb 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -3410,6 +3410,10 @@ locs)) get-result (lambda () + (define callee-save-regs + (if-feature windows + (list %rbx %rbp %rdi %rsi %r12 %r13 %r14 %r15) + (list %rbx %rbp %r12 %r13 %r14 %r15))) (in-context Tail ((lambda (e) (if adjust-active? @@ -3441,5 +3445,5 @@ (set! ,%rbp ,(%inline pop)) (set! ,%rbx ,(%inline pop)) (set! ,%sp ,(%inline + ,%sp (immediate 136))))) - (asm-c-return ,null-info ,result-regs ...)))))))))))))) + (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))) ) From d9d0e94d95710705e1fe9452704fc55286849d5f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Christian=20H=C3=A4ggstr=C3=B6m?= Date: Wed, 5 Dec 2018 23:31:38 +0100 Subject: [PATCH 15/18] Initialize more fields of seginfo original commit: 48e93161f6ac2796d17a0f147f0dca1e1e195684 --- LOG | 1 + c/segment.c | 2 ++ 2 files changed, 3 insertions(+) diff --git a/LOG b/LOG index 7bec4b119f..6af9311a2b 100644 --- a/LOG +++ b/LOG @@ -1025,3 +1025,4 @@ where the cp register copy in the thread context could be changed in the callable prep before S_call_help gets it cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms +- initialize all fields of seginfo to avoid undefined values diff --git a/c/segment.c b/c/segment.c index b578889658..28ac765165 100644 --- a/c/segment.c +++ b/c/segment.c @@ -228,7 +228,9 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) { si->space = s; si->generation = g; + si->sorted = 0; si->min_dirty_byte = 0xff; + si->trigger_ephemerons = NULL; for (d = 0; d < cards_per_segment; d += sizeof(ptr)) { iptr *dp = (iptr *)(si->dirty_bytes + d); /* fill sizeof(iptr) bytes at a time with 0xff */ From abf4ae18bb87bcb633d352c7fc993569fad13953 Mon Sep 17 00:00:00 2001 From: "R. Kent Dybvig" Date: Wed, 5 Dec 2018 15:25:21 -0800 Subject: [PATCH 16/18] Update LOG original commit: 62b92d664e166133d96cb084791ad51e57207bb1 --- LOG | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/LOG b/LOG index 6af9311a2b..e5aae978a0 100644 --- a/LOG +++ b/LOG @@ -1025,4 +1025,5 @@ where the cp register copy in the thread context could be changed in the callable prep before S_call_help gets it cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms -- initialize all fields of seginfo to avoid undefined values +- added initialization of seginfo sorted and trigger_ephemerons fields. + segment.c From b7cca1a835280fbe58b3cf14e96c5a383bb3174a Mon Sep 17 00:00:00 2001 From: "R. Kent Dybvig" Date: Wed, 5 Dec 2018 15:30:40 -0800 Subject: [PATCH 17/18] Minor tweak original commit: d2b5ba5d5c45660e63b32fb501b6684d3d11036b --- c/segment.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/c/segment.c b/c/segment.c index 28ac765165..83e3dc7707 100644 --- a/c/segment.c +++ b/c/segment.c @@ -263,7 +263,6 @@ iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; { chunk->nused_segs += 1; initialize_seginfo(si, s, g); - si->sorted = 0; si->next = S_G.occupied_segments[s][g]; S_G.occupied_segments[s][g] = si; S_G.number_of_empty_segments -= 1; @@ -302,7 +301,6 @@ iptr S_find_segments(s, g, n) ISPC s; IGEN g; iptr n; { S_G.occupied_segments[s][g] = si; for (j = n, nextsi = si; j > 0; j -= 1, nextsi = nextsi->next) { initialize_seginfo(nextsi, s, g); - nextsi->sorted = 0; } S_G.number_of_empty_segments -= n; return si->number; From c90bd7bb6d03c6d1980a0f31384350ef770eaab2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Dec 2018 05:45:08 -0700 Subject: [PATCH 18/18] experiment with a different fasl format original commit: 6e32ed2a43f6b3d8531e98dfa52a56594dd6a2f4 --- c/Mf-base | 2 +- c/externs.h | 8 + c/fasl.c | 89 ++-- c/globals.h | 5 + c/intern.c | 48 +- c/prim5.c | 2 + c/vfasl.c | 1388 +++++++++++++++++++++++++++++++++++++++++++++++++ s/back.ss | 5 + s/cmacros.ss | 4 +- s/compile.ss | 58 ++- s/primdata.ss | 2 + 11 files changed, 1570 insertions(+), 41 deletions(-) create mode 100644 c/vfasl.c diff --git a/c/Mf-base b/c/Mf-base index cc23047ba7..6042207932 100644 --- a/c/Mf-base +++ b/c/Mf-base @@ -23,7 +23,7 @@ Main=../boot/$m/main.$o Scheme=../bin/$m/scheme kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-ocd.c gc-oce.c\ - number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\ + number.c schsig.c io.c new-io.c print.c fasl.c vfasl.c stats.c foreign.c prim.c prim5.c flushcache.c\ schlib.c thread.c expeditor.c scheme.c kernelobj=${kernelsrc:%.c=%.$o} ${mdobj} diff --git a/c/externs.h b/c/externs.h index c1a2aa01fd..43d240b904 100644 --- a/c/externs.h +++ b/c/externs.h @@ -101,6 +101,13 @@ char *S_lookup_machine_type PROTO((uptr n)); extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n, ptr x, iptr o)); extern ptr S_get_code_obj PROTO((IFASLCODE typ, ptr p, iptr n, iptr o)); +extern int S_fasl_stream_read PROTO((void *stream, octet *dest, iptr n)); +extern int S_fasl_intern_rtd(ptr *x); + +/* vfasl.c */ +extern ptr S_to_vfasl PROTO((ptr v)); +extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr len)); +extern ptr S_vfasl_to PROTO((ptr v)); /* flushcache.c */ extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes)); @@ -152,6 +159,7 @@ extern void S_resize_oblist PROTO((void)); extern ptr S_intern PROTO((const unsigned char *s)); extern ptr S_intern_sc PROTO((const string_char *s, iptr n, ptr name_str)); extern ptr S_intern3 PROTO((const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str)); +extern ptr S_intern4 PROTO((ptr sym)); extern void S_intern_gensym PROTO((ptr g)); extern void S_retrofit_nonprocedure_code PROTO((void)); diff --git a/c/fasl.c b/c/fasl.c index c659c69ec2..15a4d246a2 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -237,7 +237,7 @@ static void ppc32_set_jump PROTO((void *address, uptr item, IBOOL callp)); static uptr ppc32_get_jump PROTO((void *address)); #endif /* PPC32 */ #ifdef X86_64 -static void x86_64_set_jump PROTO((void *address, uptr item, IBOOL callp)); +static void x86_64_set_jump PROTO((void *address, uptr item, IBOOL callp, IBOOL force_abs)); static uptr x86_64_get_jump PROTO((void *address)); #endif /* X86_64 */ #ifdef SPARC64 @@ -374,6 +374,11 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) { return 0; } +int S_fasl_stream_read(void *stream, octet *dest, iptr n) +{ + return uf_read((unbufFaslFile)stream, dest, n); +} + static octet uf_bytein(unbufFaslFile uf) { octet buf[1]; if (uf_read(uf, buf, 1) < 0) @@ -451,16 +456,21 @@ static ptr fasl_entry(ptr tc, unbufFaslFile uf) { ty = uf_bytein(uf); } - if (ty != fasl_type_fasl_size) + if ((ty != fasl_type_fasl_size) + && (ty != fasl_type_vfasl_size)) S_error1("", "malformed fasl-object header found in ~a", uf->path); ffo.size = uf_uptrin(uf); - ffo.buf = buf; - ffo.next = ffo.end = ffo.buf; - ffo.uf = uf; - - faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + if (ty == fasl_type_vfasl_size) { + x = S_vfasl((ptr)0, uf, ffo.size); + } else { + ffo.buf = buf; + ffo.next = ffo.end = ffo.buf; + ffo.uf = uf; + + faslin(tc, &x, S_G.null_vector, &strbuf, &ffo); + } S_flush_instruction_cache(tc); return x; @@ -694,27 +704,10 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { *x = rtd; return; } case fasl_type_rtd: { - ptr rtd, rtd_uid, plist, ls; - fasl_record(tc, x, t, pstrbuf, f); - rtd = *x; - rtd_uid = RECORDDESCUID(rtd); - - /* see if uid's property list already registers an rtd */ - plist = SYMSPLIST(rtd_uid); - for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) { - if (Scar(ls) == S_G.rtd_key) { - ptr old_rtd = Scar(Scdr(ls)); - /* if so, check new rtd against old rtd and return old rtd */ - if (!rtd_equiv(rtd, old_rtd)) - S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(rtd), f->uf->path); - *x = old_rtd; - return; - } + if (S_fasl_intern_rtd(x) < 0) { + S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(*x), f->uf->path); } - - /* if not, register it */ - SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist))); return; } case fasl_type_record: { @@ -1106,6 +1099,33 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { } } +/* Result: 0 => interned; 1 => replaced; -1 => inconsistent */ +int S_fasl_intern_rtd(ptr *x) +{ + ptr rtd, rtd_uid, plist, ls; + + rtd = *x; + rtd_uid = RECORDDESCUID(rtd); + + /* see if uid's property list already registers an rtd */ + plist = SYMSPLIST(rtd_uid); + for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) { + if (Scar(ls) == S_G.rtd_key) { + ptr old_rtd = Scar(Scdr(ls)); + /* if so, check new rtd against old rtd and return old rtd */ + if (!rtd_equiv(rtd, old_rtd)) + return -1; + else + *x = old_rtd; + return 1; + } + } + + /* if not, register it */ + SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist))); + return 0; +} + /* limited version for checking rtd fields */ static IBOOL equalp(x, y) ptr x, y; { if (x == y) return 1; @@ -1121,7 +1141,10 @@ static IBOOL equalp(x, y) ptr x, y; { } static IBOOL rtd_equiv(x, y) ptr x, y; { - return RECORDINSTTYPE(x) == RECORDINSTTYPE(y) && + return ((RECORDINSTTYPE(x) == RECORDINSTTYPE(y)) + /* recognize `base-rtd` shape: */ + || ((RECORDINSTTYPE(x) == x) + && (RECORDINSTTYPE(y) == y))) && RECORDDESCPARENT(x) == RECORDDESCPARENT(y) && equalp(RECORDDESCPM(x), RECORDDESCPM(y)) && equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) && @@ -1164,7 +1187,7 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p address = (void *)((uptr)p + n); item = (uptr)x + o; - switch (typ) { + switch (typ & ~reloc_force_abs) { case reloc_abs: *(uptr *)address = item; break; @@ -1198,10 +1221,10 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p #endif /* I386 */ #ifdef X86_64 case reloc_x86_64_jump: - x86_64_set_jump(address, item, 0); + x86_64_set_jump(address, item, 0, typ & reloc_force_abs); break; case reloc_x86_64_call: - x86_64_set_jump(address, item, 1); + x86_64_set_jump(address, item, 1, typ & reloc_force_abs); break; #endif /* X86_64 */ #ifdef SPARC64 @@ -1241,7 +1264,7 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; { void *address; uptr item; address = (void *)((uptr)p + n); - switch (typ) { + switch (typ & ~reloc_force_abs) { case reloc_abs: item = *(uptr *)address; break; @@ -1419,9 +1442,9 @@ static uptr ppc32_get_jump(void *address) { #endif /* PPC32 */ #ifdef X86_64 -static void x86_64_set_jump(void *address, uptr item, IBOOL callp) { +static void x86_64_set_jump(void *address, uptr item, IBOOL callp, IBOOL force_abs) { I64 disp = (I64)item - ((I64)address + 5); /* 5 = size of call instruction */ - if ((I32)disp == disp) { + if ((I32)disp == disp && !force_abs) { *(octet *)address = callp ? 0xE8 : 0xE9; /* call or jmp disp32 opcode */ *(I32 *)((uptr)address + 1) = (I32)disp; *((octet *)address + 5) = 0x90; /* nop */ diff --git a/c/globals.h b/c/globals.h index 86f74d89be..b3bf0b53a5 100644 --- a/c/globals.h +++ b/c/globals.h @@ -151,4 +151,9 @@ EXTERN struct { ptr eqvp; ptr equalp; ptr symboleqp; + + /* vfasl.c */ + struct vfasl_hash_table *c_entries; + struct vfasl_hash_table *library_entries; + struct vfasl_hash_table *library_entry_codes; } S_G; diff --git a/c/intern.c b/c/intern.c index acfee35393..ab530f887c 100644 --- a/c/intern.c +++ b/c/intern.c @@ -361,7 +361,7 @@ void S_intern_gensym(sym) ptr sym; { tc_mutex_release() S_error1("intern-gensym", "unique name ~s already interned", uname_str); } - if (Sstring_ref(str, i) != uname[i]) break; + if (STRIT(str, i) != uname[i]) break; } } } @@ -374,12 +374,58 @@ void S_intern_gensym(sym) ptr sym; { tc_mutex_release() } +/* must hold mutex */ +ptr S_intern4(sym) ptr sym; { + ptr name = SYMNAME(sym); + + if (name == Sfalse) { + /* gensym whose name wasn't generated, so far */ + return sym; + } else { + ptr uname_str = (Sstringp(name) ? name : Scar(name)); + if (uname_str == Sfalse) { + /* gensym that wasn't interned, so far */ + return sym; + } else { + const string_char *uname = &STRIT(uname_str, 0); + iptr ulen = Sstring_length(uname_str); + iptr hc = UNFIX(SYMHASH(sym)); + iptr idx = hc % S_G.oblist_length; + bucket *b; + + b = S_G.oblist[idx]; + while (b != NULL) { + ptr x = b->sym; + ptr x_name = SYMNAME(x); + if (Sstringp(name) == Sstringp(x_name)) { + ptr str = (Sstringp(x_name) ? x_name : Scar(x_name)); + if (Sstring_length(str) == ulen) { + iptr i; + for (i = 0; ; i += 1) { + if (i == ulen) { + return x; + } + if (STRIT(str, i) != uname[i]) break; + } + } + } + b = b->next; + } + + oblist_insert(sym, idx, GENERATION(sym)); + + return sym; + } + } +} + /* retrofit existing symbols once nonprocedure_code is available */ void S_retrofit_nonprocedure_code() { ptr npc, sym, val; bucket_list *bl; npc = S_G.nonprocedure_code; + /* FIXME */ /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */ for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) { sym = bl->car->sym; diff --git a/c/prim5.c b/c/prim5.c index bb40e6277b..6a9cb94385 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -1546,6 +1546,8 @@ void S_prim5_init() { Sforeign_symbol("(cs)getpid", (void *)s_getpid); Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read); Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read); + Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl); + Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to); Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float); Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd); diff --git a/c/vfasl.c b/c/vfasl.c new file mode 100644 index 0000000000..e36f1d3428 --- /dev/null +++ b/c/vfasl.c @@ -0,0 +1,1388 @@ +/* vfasl.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include "system.h" + +typedef uptr vfoff; + +typedef struct vfasl_header { + vfoff data_size; + vfoff table_size; + + vfoff result_offset; + + /* symbol starting offset is 0 */ +# define sym_end_offset rtd_offset + vfoff rtd_offset; +# define rtd_end_offset closure_offset + vfoff closure_offset; +# define closure_end_offset code_offset + vfoff code_offset; +# define code_end_offset other_offset + vfoff other_offset; + + vfoff symref_count; + vfoff rtdref_count; + vfoff singletonref_count; +} vfasl_header; + +/* vfasl format, where the fixed-size header determines the rest of the + size: + + [vfasl_header] + _ +d / [symbol] ... +a / [rtd] ... +t | [closure] ... +a \ [code] ... + \_ [other] ... + +t / [vfoff: symbol reference offset] ... +a / [vfoff: rtd reference offset] ... +b | [vfoff: singleton reference offset] ... +l \ +e \_ [bitmap of pointer offsets] + +*/ + +/* Many chunks per vspace on first pass, one per vspace on second + pass: */ +typedef struct vfasl_chunk { + ptr bytes; + uptr length; + uptr used; + uptr swept; + struct vfasl_chunk *next; +} vfasl_chunk; + +/* One per vspace: */ +struct vfasl_count_and_chunk { + uptr total_bytes; + vfasl_chunk *first; +}; + +enum { + /* The order of these spaces matters: */ + vspace_symbol, + vspace_rtd, + vspace_closure, + vspace_code, + /* The rest of the spaces are "other" */ + vspace_array, + vspace_typed, + vspace_reloc, + vspace_data, /* at end, so pointer bitmap ends with zeros */ + vspaces_count +}; + +typedef struct vfasl_info { + ptr base_addr; /* address to make relocations relative to */ + + uptr sym_count; + + vfoff symref_count; + vfoff *symrefs; + + ptr base_rtd; /* track replacement base_rtd to recognize other rtds */ + + vfoff rtdref_count; + vfoff *rtdrefs; + + vfoff singletonref_count; + vfoff *singletonrefs; + + struct vfasl_count_and_chunk spaces[vspaces_count]; + + octet *ptr_bitmap; + + struct vfasl_hash_table *graph; +} vfasl_info; + +#define ptr_add(p, n) ((ptr)((uptr)(p) + (n))) +#define ptr_subtract(p, n) ((ptr)((uptr)(p) - (n))) +#define ptr_diff(p, q) ((uptr)(p) - (uptr)(q)) + +#define byte_bits 8 +#define log2_byte_bits 3 + +static ptr vfasl_copy_all(vfasl_info *vfi, ptr v); + +static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si); +static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n); +static uptr sweep_code_object(vfasl_info *vfi, ptr co); +static uptr sweep_record(vfasl_info *vfi, ptr co); +static uptr sweep(vfasl_info *vfi, ptr p); + +static void relink_code(ptr co, ptr sym_base, ptr dest_base); + +static void vfasl_relocate(vfasl_info *vfi, ptr *ppp); +static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp); +static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n); +static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp); +static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p); +static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which); +static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p); +static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p); + +static void fasl_init_entry_tables(); + +static int detect_singleton(ptr p); +static ptr lookup_singleton(int which); + +typedef struct vfasl_hash_table vfasl_hash_table; +static vfasl_hash_table *make_vfasl_hash_table(); +static void free_vfasl_hash_table(vfasl_hash_table *ht); +static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value); +static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key); + +static void sort_offsets(vfoff *p, vfoff len); + +#define vfasl_fail(vfi, what) S_error("vfasl", "cannot encode " what) + +#define print_stats(args) /* printf args */ + +ptr S_vfasl(ptr bv, void *stream, iptr input_len) +{ + ptr tc = get_thread_context(); + vfasl_header header; + ptr data, table; + vfoff *symrefs, *rtdrefs, *singletonrefs; + octet *bm, *bm_end; + iptr used_len; + + used_len = sizeof(header); + if (used_len > input_len) + S_error("fasl-read", "input length mismatch"); + + if (bv) + memcpy(&header, &BVIT(bv, 0), sizeof(vfasl_header)); + else { + if (S_fasl_stream_read(stream, (octet*)&header, sizeof(header)) < 0) + S_error("fasl-read", "input truncated"); + } + + used_len += header.data_size + header.table_size; + if (used_len > input_len) + S_error("fasl-read", "input length mismatch"); + + if (bv) { + ptr base_addr = &BVIT(bv, sizeof(vfasl_header)); + thread_find_room(tc, typemod, header.data_size, data); + memcpy(data, base_addr, header.data_size); + table = ptr_add(base_addr, header.data_size); + } else { + thread_find_room(tc, typemod, header.data_size, data); + if (S_fasl_stream_read(stream, data, header.data_size) < 0) + S_error("fasl-read", "input truncated"); + + thread_find_room(tc, typemod, ptr_align(header.table_size), table); + if (S_fasl_stream_read(stream, table, header.table_size) < 0) + S_error("fasl-read", "input truncated"); + } + + symrefs = table; + rtdrefs = ptr_add(symrefs, header.symref_count * sizeof(vfoff)); + singletonrefs = ptr_add(rtdrefs, header.rtdref_count * sizeof(vfoff)); + bm = ptr_add(singletonrefs, header.singletonref_count * sizeof(vfoff)); + bm_end = ptr_add(table, header.table_size); + + if (0) + printf("\n" + "hdr %ld\n" + "syms %ld\n" + "rtds %ld\n" + "clos %ld\n" + "code %ld\n" + "othr %ld\n" + "tabl %ld symref %ld rtdref %ld sglref %ld\n", + sizeof(vfasl_header), + header.sym_end_offset, + header.rtd_end_offset - header.rtd_offset, + header.closure_end_offset - header.closure_offset, + header.code_end_offset - header.code_offset, + header.data_size - header.other_offset, + header.table_size, + header.symref_count * sizeof(vfoff), + header.rtdref_count * sizeof(vfoff), + header.singletonref_count * sizeof(vfoff)); + + /* Fix up pointers. The content `data` initially has all pointers + relative to the start of the data, so add the `data` address + to all pointers. */ + { + ptr *p = data; + while (bm != bm_end) { + octet m; + m = *bm; +# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p)[i] += (uptr)data + MAYBE_FIXUP(0); + MAYBE_FIXUP(1); + MAYBE_FIXUP(2); + MAYBE_FIXUP(3); + MAYBE_FIXUP(4); + MAYBE_FIXUP(5); + MAYBE_FIXUP(6); + MAYBE_FIXUP(7); +# undef MAYBE_FIXUP + p += byte_bits; + bm++; + } + } + + /* Intern symbols */ + { + ptr sym = TYPE(data, type_symbol); + ptr end_syms = TYPE(ptr_add(data, header.sym_end_offset), type_symbol); + + if (sym != end_syms) { + tc_mutex_acquire() + + while (sym < end_syms) { + ptr isym; + + INITSYMVAL(sym) = sunbound; + INITSYMCODE(sym,S_G.nonprocedure_code); + + isym = S_intern4(sym); + if (isym != sym) { + /* The symbol was already interned, so point to the existing one */ + INITSYMVAL(sym) = isym; + } + + sym = ptr_add(sym, size_symbol); + } + + tc_mutex_release() + } + } + + /* Replace symbol references with interned references */ + { + ptr syms = data; + vfoff i; + for (i = 0; i < header.symref_count; i++) { + uptr sym_pos; + ptr p2, sym, val; + p2 = ptr_add(data, symrefs[i]); + sym_pos = UNFIX(*(ptr **)p2); + sym = TYPE(ptr_add(syms, sym_pos * size_symbol), type_symbol); + if ((val = SYMVAL(sym)) != sunbound) + sym = val; + *(ptr **)p2 = sym; + } + } + + /* Intern rtds */ + if (header.rtd_offset < header.rtd_end_offset) { + ptr rtd = TYPE(ptr_add(data, header.rtd_offset), type_typed_object); + ptr rtd_end = TYPE(ptr_add(data, header.rtd_end_offset), type_typed_object); + + /* first one corresponds to base_rtd */ + RECORDINSTTYPE(rtd) = S_G.base_rtd; + RECORDDESCUID(rtd) = S_G.base_rtd; + + while (1) { + ptr new_rtd, parent_rtd; + + rtd = ptr_add(rtd, size_record_inst(UNFIX(RECORDDESCSIZE(S_G.base_rtd)))); + if (rtd == rtd_end) + break; + + RECORDINSTTYPE(rtd) = S_G.base_rtd; + + /* fixup type and parent before continuing, relying on parents being earlier in `rtd`s */ + parent_rtd = RECORDDESCPARENT(rtd); + if (parent_rtd != Sfalse) { + ptr parent_uid = RECORDDESCUID(parent_rtd); + if (!Ssymbolp(parent_uid)) + RECORDDESCPARENT(rtd) = parent_uid; + } + + new_rtd = rtd; + if (S_fasl_intern_rtd(&new_rtd)) { + if (new_rtd == rtd) { + S_error1("vfasl", "incompatible record type ~s", RECORDDESCNAME(rtd)); + } else { + /* Use the UID field to record already-interned replacement: */ + RECORDDESCUID(rtd) = new_rtd; + } + } + } + } + + /* Replace rtd references to interned references */ + { + vfoff i; + for (i = 0; i < header.rtdref_count; i++) { + ptr *ref, rtd, uid; + ref = ptr_add(data, rtdrefs[i]); + rtd = *ref; + uid = RECORDDESCUID(rtd); + if (!Ssymbolp(uid)) { + /* uid is replacement interned rtd */ + *ref = uid; + } + } + } + + /* Replace references to singletons like "" and #vu8() */ + { + vfoff i; + for (i = 0; i < header.singletonref_count; i++) { + ptr *ref; + ref = ptr_add(data, singletonrefs[i]); + *ref = lookup_singleton(UNFIX(*ref)); + } + } + + /* Fix code pointers on closures */ + { + ptr cl = TYPE(ptr_add(data, header.closure_offset), type_closure); + ptr end_closures = TYPE(ptr_add(data, header.closure_end_offset), type_closure); + + while (cl != end_closures) { + ptr code = CLOSCODE(cl); + code = ptr_add(code, (uptr)data); + SETCLOSCODE(cl,code); + cl = ptr_add(cl, size_closure(CLOSLEN(cl))); + } + } + + /* Fix code via relocations */ + { + + ptr sym_base = data; + ptr code = TYPE(ptr_add(data, header.code_offset), type_typed_object); + ptr code_end = TYPE(ptr_add(data, header.code_end_offset), type_typed_object); + while (code != code_end) { + relink_code(code, sym_base, data); + code = ptr_add(code, size_code(CODELEN(code))); + } + } + + /* Turn result offset into a value, unboxing if it's a box (which + supports a symbol result, for example). */ + { + ptr v; + ITYPE t; + v = ptr_add(data, header.result_offset); + if (((t = TYPEBITS(v)) == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_box, type_box)) + v = Sunbox(v); + + return v; + } +} + +ptr S_vfasl_to(ptr bv) +{ + return S_vfasl(bv, (ptr)0, Sbytevector_length(bv)); +} + +ptr S_to_vfasl(ptr v) +{ + vfasl_info *vfi; + vfasl_header header; + ITYPE t; + int s; + uptr size, data_size, bitmap_size, pre_bitmap_size; + ptr bv, p; + + fasl_init_entry_tables(); + + /* Box certain kinds of values where the vfasl process needs a + pointer into data */ + if (IMMEDIATE(v) + || detect_singleton(v) + || ((t = TYPEBITS(v)) == type_symbol) + || ((t == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_record, type_record) + && (TYPEFIELD(v) == v)) + || ((t == type_typed_object) + && TYPEP(TYPEFIELD(v), mask_box, type_box))) { + v = Sbox(v); + } + + vfi = malloc(sizeof(vfasl_info)); + + vfi->base_addr = (ptr)0; + vfi->sym_count = 0; + vfi->symref_count = 0; + vfi->symrefs = (ptr)0; + vfi->base_rtd = S_G.base_rtd; + vfi->rtdref_count = 0; + vfi->rtdrefs = (ptr)0; + vfi->singletonref_count = 0; + vfi->singletonrefs = (ptr)0; + vfi->graph = make_vfasl_hash_table(); + vfi->ptr_bitmap = (ptr)0; + + /* First pass: determine sizes */ + + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = (ptr)0; + c->length = 0; + c->used = 0; + c->swept = 0; + c->next = (ptr)0; + + vfi->spaces[s].first = c; + vfi->spaces[s].total_bytes = 0; + } + + (void)vfasl_copy_all(vfi, v); + + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c, *next; + for (c = vfi->spaces[s].first; c; c = next) { + next = c->next; + free(c->bytes); + free(c); + } + } + + free_vfasl_hash_table(vfi->graph); + + /* Setup for second pass: allocate to contiguous bytes */ + + size = sizeof(vfasl_header); + + data_size = 0; + for (s = 0; s < vspaces_count; s++) { + data_size += vfi->spaces[s].total_bytes; + } + header.data_size = data_size; + size += data_size; + + size += vfi->symref_count * sizeof(vfoff); + size += vfi->rtdref_count * sizeof(vfoff); + size += vfi->singletonref_count * sizeof(vfoff); + + header.table_size = size - data_size - sizeof(header); /* doesn't yet include the bitmap */ + + header.rtd_offset = vfi->spaces[vspace_symbol].total_bytes; + header.closure_offset = header.rtd_offset + vfi->spaces[vspace_rtd].total_bytes; + header.code_offset = header.closure_offset + vfi->spaces[vspace_closure].total_bytes; + header.other_offset = header.code_offset + vfi->spaces[vspace_code].total_bytes; + + header.symref_count = vfi->symref_count; + header.rtdref_count = vfi->rtdref_count; + header.singletonref_count = vfi->singletonref_count; + + pre_bitmap_size = size; + + bitmap_size = (data_size + (byte_bits-1)) >> log2_byte_bits; + + size += bitmap_size; + + bv = S_bytevector(size); + memset(&BVIT(bv, 0), 0, size); + + p = &BVIT(bv, 0); + + /* Skip header for now */ + p = ptr_add(p, sizeof(vfasl_header)); + + vfi->base_addr = p; + + /* Set pointers to vspaces based on sizes frm first pass */ + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = p; + c->length = vfi->spaces[s].total_bytes; + c->used = 0; + c->swept = 0; + c->next = (ptr)0; + vfi->spaces[s].first = c; + + p = ptr_add(p, vfi->spaces[s].total_bytes); + vfi->spaces[s].total_bytes = 0; + } + + vfi->symrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->symref_count); + + vfi->base_rtd = S_G.base_rtd; + vfi->rtdrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->rtdref_count); + + vfi->singletonrefs = p; + p = ptr_add(p, sizeof(vfoff) * vfi->singletonref_count); + + vfi->sym_count = 0; + vfi->symref_count = 0; + vfi->rtdref_count = 0; + vfi->singletonref_count = 0; + + vfi->graph = make_vfasl_hash_table(); + + vfi->ptr_bitmap = p; + + /* Write data */ + + v = vfasl_copy_all(vfi, v); + + header.result_offset = ptr_diff(v, vfi->base_addr); + + /* Make all pointers relative to the start of the data area */ + { + ptr *p2 = vfi->base_addr; + uptr base_addr = (uptr)vfi->base_addr; + octet *bm = vfi->ptr_bitmap; + octet *bm_end = bm + bitmap_size; + uptr zeros = 0; + for (; bm != bm_end; bm++, p2 += byte_bits) { + octet m = *bm; + if (m == 0) { + zeros++; + } else { +# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p2)[i] -= base_addr; + MAYBE_FIXUP(0); + MAYBE_FIXUP(1); + MAYBE_FIXUP(2); + MAYBE_FIXUP(3); + MAYBE_FIXUP(4); + MAYBE_FIXUP(5); + MAYBE_FIXUP(6); + MAYBE_FIXUP(7); +# undef MAYBE_FIXUP + zeros = 0; + } + } + + /* We can ignore trailing zeros */ + header.table_size += (bitmap_size - zeros); + } + + /* Truncate bytevector to match end of bitmaps */ + { + uptr sz = sizeof(vfasl_header) + header.data_size + header.table_size; + BYTEVECTOR_TYPE(bv) = (sz << bytevector_length_offset) | type_bytevector; + } + + memcpy(&BVIT(bv, 0), &header, sizeof(vfasl_header)); + + sort_offsets(vfi->symrefs, vfi->symref_count); + sort_offsets(vfi->rtdrefs, vfi->rtdref_count); + sort_offsets(vfi->singletonrefs, vfi->singletonref_count); + + for (s = 0; s < vspaces_count; s++) { + free(vfi->spaces[s].first); + } + + free_vfasl_hash_table(vfi->graph); + + free(vfi); + + return bv; +} + +static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { + seginfo *si; + int s; + int changed = 1; + + si = MaybeSegInfo(ptr_get_segment(v)); + + v = copy(vfi, v, si); + + while (changed) { + changed = 0; + for (s = 0; s < vspaces_count; s++) { + vfasl_chunk *c = vfi->spaces[s].first; + while (c && (c->swept < c->used)) { + ptr pp, pp_end; + + pp = ptr_add(c->bytes, c->swept); + pp_end = ptr_add(c->bytes, c->used); + c->swept = c->used; + + switch(s) { + case vspace_symbol: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_symbol))); + } + break; + case vspace_closure: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_closure))); + } + break; + case vspace_array: + while (pp < pp_end) { + vfasl_relocate(vfi, pp); + pp = ptr_add(pp, sizeof(ptr)); + } + break; + case vspace_rtd: + case vspace_code: + case vspace_typed: + while (pp < pp_end) { + pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_typed_object))); + } + break; + case vspace_data: + case vspace_reloc: + break; + default: + S_error_abort("vfasl: unrecognized space"); + break; + } + + c = c->next; + changed = 1; + } + } + } + + return v; +} + +static void vfasl_register_pointer(vfasl_info *vfi, ptr *pp) { + if (vfi->ptr_bitmap) { + uptr delta = ptr_diff(pp, vfi->base_addr) >> log2_ptr_bytes; + uptr i = delta >> log2_byte_bits; + uptr bit = (((uptr)1) << (delta & (byte_bits - 1))); + vfi->ptr_bitmap[i] |= bit; + } +} + +static uptr ptr_base_diff(vfasl_info *vfi, ptr p) { + if ((uptr)vfi->base_addr > (uptr)UNTYPE(p, TYPEBITS(p))) + S_error_abort("vfasl: pointer not in region"); + + return ptr_diff(p, vfi->base_addr); +} + +static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p) { + if (vfi->symrefs) + vfi->symrefs[vfi->symref_count] = ptr_base_diff(vfi, pp); + vfi->symref_count++; + *pp = SYMVAL(p); /* replace symbol reference with index of symbol */ +} + +static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp) { + if (vfi->rtdrefs) + vfi->rtdrefs[vfi->rtdref_count] = ptr_base_diff(vfi, pp); + vfi->rtdref_count++; +} + +static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which) { + if (vfi->singletonrefs) + vfi->singletonrefs[vfi->singletonref_count] = ptr_base_diff(vfi, pp); + vfi->singletonref_count++; + *pp = FIX(which); +} + +static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p) { + vfasl_hash_table_set(vfi->graph, pp, p); +} + +static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p) { + return vfasl_hash_table_ref(vfi->graph, p); +} + +static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { + ptr p; + + vfi->spaces[s].total_bytes += n; + + if (vfi->spaces[s].first->used + n > vfi->spaces[s].first->length) { + vfasl_chunk *c; + iptr newlen = n * 2; + if (newlen < 4096) + newlen = 4096; + + c = malloc(sizeof(vfasl_chunk)); + c->bytes = malloc(newlen); + c->length = newlen; + c->used = 0; + c->swept = 0; + + c->next = vfi->spaces[s].first; + vfi->spaces[s].first = c; + } + + p = ptr_add(vfi->spaces[s].first->bytes, vfi->spaces[s].first->used); + vfi->spaces[s].first->used += n; + + return TYPE(p, t); +} + +#define FIND_ROOM(vfi, s, t, n, p) p = vfasl_find_room(vfi, s, t, n) + +#define copy_ptrs(ty, p1, p2, n) {\ + ptr *Q1, *Q2, *Q1END;\ + Q1 = (ptr *)UNTYPE((p1),ty);\ + Q2 = (ptr *)UNTYPE((p2),ty);\ + Q1END = (ptr *)((uptr)Q1 + n);\ + while (Q1 != Q1END) *Q1++ = *Q2++;} + +static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si) { + ptr p, tf; ITYPE t; + + if ((t = TYPEBITS(pp)) == type_typed_object) { + tf = TYPEFIELD(pp); + if (TYPEP(tf, mask_record, type_record)) { + ptr rtd; iptr n; int s; + + rtd = tf; + + if (tf == S_G.base_rtd) { + if ((pp != S_G.base_rtd) && (vfi->base_rtd == S_G.base_rtd)) { + /* make sure base_rtd is first one registered */ + (void)vfasl_relocate_help(vfi, S_G.base_rtd); + } + /* need type and parent before child; FIXME: stack overflow possible */ + if (RECORDDESCPARENT(pp) != Sfalse) { + (void)vfasl_relocate_help(vfi, RECORDDESCPARENT(pp)); + } + + s = vspace_rtd; + } else + s = vspace_typed; + + n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + + FIND_ROOM(vfi, s, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + + if (pp == S_G.base_rtd) + vfi->base_rtd = p; + } else if (TYPEP(tf, mask_vector, type_vector)) { + iptr len, n; + len = Svector_length(pp); + n = size_vector(len); + FIND_ROOM(vfi, vspace_typed, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_string, type_string)) { + iptr n; + n = size_string(Sstring_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_fxvector, type_fxvector)) { + iptr n; + n = size_fxvector(Sfxvector_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + iptr n; + n = size_bytevector(Sbytevector_length(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if ((iptr)tf == type_tlc) { + vfasl_fail(vfi, "tlc"); + return (ptr)0; + } else if (TYPEP(tf, mask_box, type_box)) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_box, p); + BOXTYPE(p) = (iptr)tf; + INITBOXREF(p) = Sunbox(pp); + } else if ((iptr)tf == type_ratnum) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_ratnum, p); + RATTYPE(p) = type_ratnum; + RATNUM(p) = RATNUM(pp); + RATDEN(p) = RATDEN(pp); + } else if ((iptr)tf == type_exactnum) { + FIND_ROOM(vfi, vspace_typed, type_typed_object, size_exactnum, p); + EXACTNUM_TYPE(p) = type_exactnum; + EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp); + EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp); + } else if ((iptr)tf == type_inexactnum) { + FIND_ROOM(vfi, vspace_data, type_typed_object, size_inexactnum, p); + INEXACTNUM_TYPE(p) = type_inexactnum; + INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp); + INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp); + } else if (TYPEP(tf, mask_bignum, type_bignum)) { + iptr n; + n = size_bignum(BIGLEN(pp)); + FIND_ROOM(vfi, vspace_data, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + } else if (TYPEP(tf, mask_port, type_port)) { + vfasl_fail(vfi, "port"); + return (ptr)0; + } else if (TYPEP(tf, mask_code, type_code)) { + iptr n; + n = size_code(CODELEN(pp)); + FIND_ROOM(vfi, vspace_code, type_typed_object, n, p); + copy_ptrs(type_typed_object, p, pp, n); + if (CODERELOC(pp) == (ptr)0) { + /* We only get here if we're vfasling code that belongs in + the static generation. */ + ptr l; iptr ln; + ln = size_reloc_table(0); + FIND_ROOM(vfi, vspace_reloc, typemod, ln, l); + RELOCSIZE(l) = 0; + RELOCCODE(l) = p; + CODERELOC(p) = l; + vfasl_register_pointer(vfi, &CODERELOC(p)); + } + } else if ((iptr)tf == type_rtd_counts) { + /* prune counts, since GC will recreate as needed */ + return Sfalse; + } else if ((iptr)tf == type_thread) { + vfasl_fail(vfi, "thread"); + return (ptr)0; + } else { + S_error_abort("vfasl: illegal type"); + return (ptr)0 /* not reached */; + } + } else if (t == type_pair) { + if (si->space == space_ephemeron) { + vfasl_fail(vfi, "emphemeron"); + return (ptr)0; + } else if (si->space == space_weakpair) { + vfasl_fail(vfi, "weakpair"); + return (ptr)0; + } else { + FIND_ROOM(vfi, vspace_array, type_pair, size_pair, p); + } + INITCAR(p) = Scar(pp); + INITCDR(p) = Scdr(pp); + } else if (t == type_closure) { + ptr code; + code = CLOSCODE(pp); + if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) { + vfasl_fail(vfi, "continuation"); + return (ptr)0; + } else { + iptr len, n; + len = CLOSLEN(pp); + n = size_closure(len); + FIND_ROOM(vfi, vspace_closure, type_closure, n, p); + copy_ptrs(type_closure, p, pp, n); + } + } else if (t == type_symbol) { + iptr pos = vfi->sym_count++; + FIND_ROOM(vfi, vspace_symbol, type_symbol, size_symbol, p); + INITSYMVAL(p) = FIX(pos); /* stores symbol index for now; will get reset on load */ + INITSYMPVAL(p) = Snil; /* will get reset on load */ + INITSYMPLIST(p) = Snil; + INITSYMSPLIST(p) = Snil; + INITSYMNAME(p) = SYMNAME(pp); + INITSYMHASH(p) = SYMHASH(pp); + } else if (t == type_flonum) { + FIND_ROOM(vfi, vspace_data, type_flonum, size_flonum, p); + FLODAT(p) = FLODAT(pp); + /* note: unlike GC, sharing flonums */ + } else { + S_error_abort("copy(gc): illegal type"); + return (ptr)0 /* not reached */; + } + + vfasl_register_forward(vfi, pp, p); + + return p; +} + +static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp) { + ptr fpp; + seginfo *si; + + si = MaybeSegInfo(ptr_get_segment(pp)); + if (!si) + vfasl_fail(vfi, "unknown"); + + fpp = vfasl_lookup_forward(vfi, pp); + if (fpp) + return fpp; + else + return copy(vfi, pp, si); +} + +/* Use vfasl_relocate only on addresses that are in the vfasl target area */ +static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) { + ptr pp = *ppp, tf; + if (!IMMEDIATE(pp)) { + int which_singleton; + if ((which_singleton = detect_singleton(pp))) + vfasl_register_singleton_reference(vfi, ppp, which_singleton); + else { + pp = vfasl_relocate_help(vfi, pp); + *ppp = pp; + if (!IMMEDIATE(pp)) { + if (TYPEBITS(pp) == type_symbol) + vfasl_register_symbol_reference(vfi, ppp, pp); + else { + if ((TYPEBITS(pp) == type_typed_object) + && (((tf = TYPEFIELD(pp)) == vfi->base_rtd) + || (tf == S_G.base_rtd))) + vfasl_register_rtd_reference(vfi, ppp); + vfasl_register_pointer(vfi, ppp); + } + } + } + } +} + +static void sweep_ptrs(vfasl_info *vfi, ptr *pp, iptr n) { + ptr *end = pp + n; + + while (pp != end) { + vfasl_relocate(vfi, pp); + pp += 1; + } +} + +static uptr sweep(vfasl_info *vfi, ptr p) { + ptr tf; ITYPE t; + + t = TYPEBITS(p); + if (t == type_closure) { + uptr len; + ptr code; + + len = CLOSLEN(p); + sweep_ptrs(vfi, &CLOSIT(p, 0), len); + + /* To code-entry pointer looks like an immediate to + sweep, so relocate the code directly, and also make it + relative to the base address. */ + code = vfasl_relocate_help(vfi, CLOSCODE(p)); + code = (ptr)ptr_diff(code, vfi->base_addr); + SETCLOSCODE(p,code); + + return size_closure(len); + } else if (t == type_symbol) { + vfasl_relocate(vfi, &INITSYMNAME(p)); + /* other parts are replaced on load */ + return size_symbol; + } else if (t == type_flonum) { + /* nothing to sweep */; + return size_flonum; + /* typed objects */ + } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) { + uptr len = Svector_length(p); + sweep_ptrs(vfi, &INITVECTIT(p, 0), len); + return size_vector(len); + } else if (TYPEP(tf, mask_record, type_record)) { + return sweep_record(vfi, p); + } else if (TYPEP(tf, mask_box, type_box)) { + vfasl_relocate(vfi, &INITBOXREF(p)); + return size_box; + } else if ((iptr)tf == type_ratnum) { + vfasl_relocate(vfi, &RATNUM(p)); + vfasl_relocate(vfi, &RATDEN(p)); + return size_ratnum; + } else if ((iptr)tf == type_exactnum) { + vfasl_relocate(vfi, &EXACTNUM_REAL_PART(p)); + vfasl_relocate(vfi, &EXACTNUM_IMAG_PART(p)); + return size_exactnum; + } else if (TYPEP(tf, mask_code, type_code)) { + return sweep_code_object(vfi, p); + } else { + S_error_abort("vfasl_sweep: illegal type"); + return 0; + } +} + +static uptr sweep_record(vfasl_info *vfi, ptr x) +{ + ptr *pp; ptr num; ptr rtd; + + rtd = RECORDINSTTYPE(x); + if (rtd == S_G.base_rtd) { + /* base-rtd is reset directly in all rtds */ + RECORDINSTTYPE(x) = vfi->base_rtd; + + if (x == vfi->base_rtd) { + /* Don't need to save fields of base-rtd */ + ptr *pp = &RECORDINSTIT(x,0); + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; + while (pp < ppend) { + *pp = Snil; + pp += 1; + } + return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); + } + } else + vfasl_relocate(vfi, &RECORDINSTTYPE(x)); + + num = RECORDDESCPM(rtd); + pp = &RECORDINSTIT(x,0); + + /* process cells for which bit in pm is set; quit when pm == 0. */ + if (Sfixnump(num)) { + /* ignore bit for already forwarded rtd */ + uptr mask = (uptr)UNFIX(num) >> 1; + if (mask == (uptr)-1 >> 1) { + ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1; + while (pp < ppend) { + vfasl_relocate(vfi, pp); + pp += 1; + } + } else { + while (mask != 0) { + if (mask & 1) vfasl_relocate(vfi, pp); + mask >>= 1; + pp += 1; + } + } + } else { + iptr index; bigit mask; INT bits; + + /* bignum pointer mask */ + num = RECORDDESCPM(rtd); + vfasl_relocate(vfi, &RECORDDESCPM(rtd)); + index = BIGLEN(num) - 1; + /* ignore bit for already forwarded rtd */ + mask = BIGIT(num,index) >> 1; + bits = bigit_bits - 1; + for (;;) { + do { + if (mask & 1) vfasl_relocate(vfi, pp); + mask >>= 1; + pp += 1; + } while (--bits > 0); + if (index-- == 0) break; + mask = BIGIT(num,index); + bits = bigit_bits; + } + } + + return size_record_inst(UNFIX(RECORDDESCSIZE(rtd))); +} + +#define VFASL_RELOC_TAG_BITS 3 + +#define VFASL_RELOC_C_ENTRY_TAG 1 +#define VFASL_RELOC_LIBRARY_ENTRY_TAG 2 +#define VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG 3 +#define VFASL_RELOC_SYMBOL_TAG 4 +#define VFASL_RELOC_SINGLETON_TAG 5 +/* FXIME: rtds? */ + +#define VFASL_RELOC_C_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_C_ENTRY_TAG) +#define VFASL_RELOC_LIBRARY_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_TAG) +#define VFASL_RELOC_LIBRARY_ENTRY_CODE(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) +#define VFASL_RELOC_SYMBOL(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SYMBOL_TAG) +#define VFASL_RELOC_SINGLETON(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SINGLETON_TAG) + +#define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1)) +#define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS) + +static uptr sweep_code_object(vfasl_info *vfi, ptr co) { + ptr t, oldco, oldt; iptr a, m, n; + + vfasl_relocate(vfi, &CODENAME(co)); + vfasl_relocate(vfi, &CODEARITYMASK(co)); + vfasl_relocate(vfi, &CODEINFO(co)); + vfasl_relocate(vfi, &CODEPINFOS(co)); + + oldt = CODERELOC(co); + + n = size_reloc_table(RELOCSIZE(oldt)); + t = vfasl_find_room(vfi, vspace_reloc, typemod, n); + copy_ptrs(typemod, t, oldt, n); + + m = RELOCSIZE(t); + oldco = RELOCCODE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj, pos; + int which_singleton; + + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + + if ((which_singleton = detect_singleton(obj))) { + obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); + } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { + obj = FIX(VFASL_RELOC_C_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); + } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) { + obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos)); + } else if (Ssymbolp(obj)) { + obj = vfasl_relocate_help(vfi, obj); + obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj)))); + } else if (IMMEDIATE(obj)) { + /* as-is */ + if (Sfixnump(obj)) + S_error("vfasl", "unexpected fixnum in relocation"); + } else { + obj = vfasl_relocate_help(vfi, obj); + obj = (ptr)ptr_diff(obj, vfi->base_addr); + } + + S_set_code_obj("vfasl", RELOC_TYPE(entry) | reloc_force_abs, co, a, obj, item_off); + } + + RELOCCODE(t) = co; + CODERELOC(co) = t; + + vfasl_register_pointer(vfi, &RELOCCODE(t)); + vfasl_register_pointer(vfi, &CODERELOC(co)); + + return size_code(CODELEN(co)); +} + +static void relink_code(ptr co, ptr sym_base, ptr dest_base) { + ptr t; iptr a, m, n; + + t = CODERELOC(co); + + m = RELOCSIZE(t); + a = 0; + n = 0; + while (n < m) { + uptr entry, item_off, code_off; ptr obj; + + entry = RELOCIT(t, n); n += 1; + if (RELOC_EXTENDED_FORMAT(entry)) { + item_off = RELOCIT(t, n); n += 1; + code_off = RELOCIT(t, n); n += 1; + } else { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a += code_off; + obj = S_get_code_obj(RELOC_TYPE(entry) | reloc_force_abs, co, a, item_off); + + if (IMMEDIATE(obj)) { + if (Sfixnump(obj)) { + int tag = VFASL_RELOC_TAG(obj); + int pos = VFASL_RELOC_POS(obj); + if (tag == VFASL_RELOC_SINGLETON_TAG) + obj = lookup_singleton(pos); + else if (tag == VFASL_RELOC_C_ENTRY_TAG) + obj = S_lookup_c_entry(pos); + else if ((tag == VFASL_RELOC_LIBRARY_ENTRY_TAG) + || (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG)) { + obj = S_lookup_library_entry(pos, 1); + if (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) + obj = CLOSCODE(obj); + } else if (tag == VFASL_RELOC_SYMBOL_TAG) { + ptr val; + obj = TYPE(ptr_add(sym_base, pos * size_symbol), type_symbol); + if ((val = SYMVAL(obj)) != sunbound) + obj = val; + } else { + S_error_abort("vfasl: bad relocation tag"); + } + } else { + /* some other immediate, such as black-hole; leave as-is */ + } + } else { + uptr offset = (uptr)obj; + obj = ptr_add(dest_base, offset); + if ((TYPEBITS(obj) == type_typed_object) + && (TYPEFIELD(obj) == S_G.base_rtd)) { + /* Similar to symbols: potentially replace with interned */ + ptr uid = RECORDDESCUID(obj); + if (!Ssymbolp(uid)) { + /* "uid" is actually the interned rtd to use instead */ + obj = uid; + } + } + } + + S_set_code_obj("vfasl", RELOC_TYPE(entry), co, a, obj, item_off); + } +} + +/*************************************************************/ + +static void fasl_init_entry_tables() +{ + tc_mutex_acquire() + + if (!S_G.c_entries) { + iptr i; + + S_G.c_entries = make_vfasl_hash_table(); + S_G.library_entries = make_vfasl_hash_table(); + S_G.library_entry_codes = make_vfasl_hash_table(); + + for (i = Svector_length(S_G.c_entry_vector); i--; ) { + ptr entry = Svector_ref(S_G.c_entry_vector, i); + vfasl_hash_table_set(S_G.c_entries, entry, (ptr)i); + } + + for (i = Svector_length(S_G.library_entry_vector); i--; ) { + ptr entry = Svector_ref(S_G.library_entry_vector, i); + if (entry != Sfalse) { + vfasl_hash_table_set(S_G.library_entries, entry, (ptr)i); + vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)i); + } + } + } + + tc_mutex_release() +} + +/*************************************************************/ + +static int detect_singleton(ptr p) { + if (p == S_G.null_string) + return 1; + else if (p == S_G.null_vector) + return 2; + else if (p == S_G.null_fxvector) + return 3; + else if (p == S_G.null_bytevector) + return 4; + else + return 0; +} + +static ptr lookup_singleton(int which) { + switch (which) { + case 1: + return S_G.null_string; + case 2: + return S_G.null_vector; + case 3: + return S_G.null_fxvector; + case 4: + return S_G.null_bytevector; + default: + S_error("vfasl", "bad singleton index"); + return (ptr)0; + } +} + +/*************************************************************/ + +typedef struct hash_entry { + ptr key, value; +} hash_entry; + +struct vfasl_hash_table { + uptr count; + uptr size; + hash_entry *entries; +}; + +#define HASH_CODE(p) ((uptr)(p) >> log2_ptr_bytes) +#define HASH_CODE2(p) (((uptr)(p) >> (log2_ptr_bytes + log2_ptr_bytes)) | 1) + +static vfasl_hash_table *make_vfasl_hash_table() { + vfasl_hash_table *ht; + + ht = malloc(sizeof(vfasl_hash_table)); + + ht->count = 0; + ht->size = 16; + ht->entries = calloc(sizeof(hash_entry), ht->size); + + return ht; +} + +static void free_vfasl_hash_table(vfasl_hash_table *ht) { + free(ht->entries); + free(ht); +} + +static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value) { + uptr hc = HASH_CODE(key); + uptr hc2 = HASH_CODE2(key); + uptr size = ht->size; + + if (ht->count > ht->size >> 1) { + /* rehash */ + uptr i; + hash_entry *old_entries = ht->entries; + + ht->count = 0; + ht->size *= 2; + ht->entries = calloc(sizeof(hash_entry), ht->size); + + for (i = 0; i < size; i++) { + if (old_entries[i].key) + vfasl_hash_table_set(ht, old_entries[i].key, old_entries[i].value); + } + + free(old_entries); + size = ht->size; + } + + hc = hc & (size - 1); + while (ht->entries[hc].key) { + hc = (hc + hc2) & (size - 1); + } + + ht->entries[hc].key = key; + ht->entries[hc].value = value; + ht->count++; +} + +static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key) { + uptr hc = HASH_CODE(key); + uptr hc2 = HASH_CODE2(key); + uptr size = ht->size; + ptr old_key; + + hc = hc & (size - 1); + while ((old_key = ht->entries[hc].key) != key) { + if (!old_key) + return (ptr)0; + hc = (hc + hc2) & (size - 1); + } + + return ht->entries[hc].value; +} + +/*************************************************************/ + +static void sort_offsets(vfoff *p, vfoff len) +{ + while (1) { + if (len > 1) { + vfoff i, pivot = 0; + + { + vfoff mid = len >> 2; + vfoff tmp = p[mid]; + p[mid] = p[0]; + p[0] = tmp; + } + + for (i = 1; i < len; i++) { + if (p[i] < p[pivot]) { + vfoff tmp = p[pivot]; + p[pivot] = p[i]; + pivot++; + p[i] = p[pivot]; + p[pivot] = tmp; + } + } + + if (pivot > (len >> 1)) { + sort_offsets(p+pivot+1, len-pivot-1); + len = pivot; + } else { + sort_offsets(p, pivot); + p = p+pivot+1; + len = len-pivot-1; + } + } else + return; + } +} diff --git a/s/back.ss b/s/back.ss index 7f8b59fe99..9f9ae878ec 100644 --- a/s/back.ss +++ b/s/back.ss @@ -126,6 +126,11 @@ (lambda (x) (and x #t)))) +(define generate-vfasl + ($make-thread-parameter #f + (lambda (x) + (and x #t)))) + (define $enable-check-prelex-flags ($make-thread-parameter #f (lambda (x) diff --git a/s/cmacros.ss b/s/cmacros.ss index b034522e29..a44d4f0680 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -433,7 +433,7 @@ (define-constant fasl-type-graph-ref 18) (define-constant fasl-type-gensym 19) (define-constant fasl-type-exactnum 20) -; 21 +(define-constant fasl-type-vfasl-size 21) (define-constant fasl-type-fasl-size 22) (define-constant fasl-type-record 23) (define-constant fasl-type-rtd 24) @@ -498,6 +498,8 @@ (arm32 reloc-arm32-abs reloc-arm32-call reloc-arm32-jump) (ppc32 reloc-ppc32-abs reloc-ppc32-call reloc-ppc32-jump)) +(define-constant reloc-force-abs #x100) ; flag to add to other `reloc-` constants + (constant-case ptr-bits [(64) (define-constant reloc-extended-format #x1) diff --git a/s/compile.ss b/s/compile.ss index 10a961e66b..cff5d41734 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -22,6 +22,7 @@ (define $c-make-code) (define make-boot-header) (define make-boot-file) +(define vfasl-convert-file) (let () (import (nanopass)) @@ -440,10 +441,32 @@ [else (c-assembler-output-error x)]))) (define (c-print-fasl x p) - (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))]) - (c-build-fasl x t a?) - ($fasl-start p t - (lambda (p) (c-faslobj x t p a?))))) + (cond + [(generate-vfasl) (c-print-vfasl x p)] + [else + (let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))]) + (c-build-fasl x t a?) + ($fasl-start p t + (lambda (p) (c-faslobj x t p a?))))])) + +(define (c-vfaslobj x) + (let f ([x x]) + (record-case x + [(group) elt* + (apply vector (map c-vfaslobj elt*))] + [(visit-stuff) elt + (cons (constant visit-tag) (c-vfaslobj x))] + [(revisit-stuff) elt + (cons (constant revisit-tag) (c-vfaslobj x))] + [else (c-mkcode x)]))) + +(define c-print-vfasl + (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]) + (lambda (x p) + (let ([bv (->vfasl (c-vfaslobj x))]) + (put-u8 p (constant fasl-type-vfasl-size)) + (put-uptr p (bytevector-length bv)) + (put-bytevector p bv))))) (define-record-type visit-chunk (nongenerative) @@ -1588,7 +1611,32 @@ (set-who! $make-boot-header ; create boot loader (invoke) for entry into Scheme from C (lambda (out machine . bootfiles) - (do-make-boot-header who out machine bootfiles)))) + (do-make-boot-header who out machine bootfiles))) + + (set-who! vfasl-convert-file + (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]) + (lambda (in-file out-file bootfile*) + (let ([op ($open-file-output-port who out-file + (if (compile-compressed) + (file-options replace compressed) + (file-options replace)))]) + (on-reset (delete-file out-file #f) + (on-reset (close-port op) + (when bootfile* + (emit-boot-header op (constant machine-type) bootfile*)) + (let ([ip ($open-file-input-port who in-file (file-options compressed))]) + (on-reset (close-port ip) + (let loop () + (let ([x (fasl-read ip)]) + (unless (eof-object? x) + (emit-header op (constant machine-type)) + (let ([bv (->vfasl x)]) + (put-u8 op (constant fasl-type-vfasl-size)) + (put-uptr op (bytevector-length bv)) + (put-bytevector op bv)) + (loop)))) + (close-port ip))) + (close-port op)))))))) (set-who! compile-port (rec compile-port diff --git a/s/primdata.ss b/s/primdata.ss index 0e829857eb..f4d086d572 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -960,6 +960,7 @@ (generate-interrupt-trap [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (generate-procedure-source-information [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (generate-profile-forms [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) + (generate-vfasl [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (generate-wpo-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (gensym-count [sig [() -> (uint)] [(uint) -> (void)]] [flags]) (gensym-prefix [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted]) @@ -1278,6 +1279,7 @@ (fasl-file [sig [(pathname pathname) -> (void)]] [flags true]) (fasl-read [sig [(binary-input-port) -> (ptr)]] [flags true]) (fasl-write [sig [(sub-ptr binary-output-port) -> (void)]] [flags true]) + (vfasl-convert-file [sig [(ptr ptr ptr) -> (void)]] [flags]) (file-access-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-change-time [sig [(pathname) (pathname ptr) -> (time)]] [flags discard]) (file-directory? [sig [(pathname) (pathname ptr) -> (boolean)]] [flags discard])