7d145e37a8
and functionality improvements (including support for measuring
coverage), primitive argument-checking fixes, and object-file changes
resulting in reduced load times (and some backward incompatibility):
- annotations are now preserved in object files for debug
only, for profiling only, for both, or not at all, depending
on the settings of generate-inspector-information and
compile-profile. in particular, when inspector information
is not enabled but profiling is, source information does
not leak into error messages and inspector output, though it is
still available via the profile tools. The mechanics of this
involved repurposing the fasl a? parameter to hold an annotation
flags value when it is not #f and remaking annotations with
new flags if necessary before emitting them.
compile.ss, fasl.ss, misc.ms
- altered a number of mats to produce correct results even
when the 's' directory is profiled.
misc.ms, cp0.ms, record.ms
- profile-release-counters is now generation-friendly; that is,
it doesn't look for dropped code objects in generations that have
not been collected since the last call to profile-release-counters.
also, it no longer allocates memory when it releases counters.
pdhtml.ss,
gc.c, gcwrapper.c, globals.h, prim5.c
- removed unused entry points S_ifile, S_ofile, and S_iofile
alloc.c, externs.h
- mats that test loading profile info into the compiler's database
to guide optimization now weed out preexisting entries, in case
the 's' directory is profiled.
4.ms, mat.ss, misc.ms, primvars.ms
- counters for dropped code objects are now released at the start
of each mat group.
mat.ss
- replaced ehc (enable-heap-check) option with hci (heap-check-interval)
option that allows heap checks to be performed periodically rather
than on each collection. hci=0 is equivalent to ehc=f (disabling
heap checks) and hci=1 is equivalent to ehc=t (enabling heap
checks every collection), while hci=100 enables heap checks only
every 100th collection. allx and bullyx mats use this feature
to reduce heap-checking overhead to a more reasonable level. this
is particularly important when the 's' directory is profiled,
since the amount of static memory to be checked is greatly increased
due to the counters.
mats/Mf-base, mat.ss, primvars.ms
- added a mat that calls #%show-allocation, which was otherwise not
being tested.
misc.ms
- removed a broken primvars mat and updated two others. in each case,
the mat was looking for information about primitives in the wrong
(i.e., old) place and silently succeeding when it didn't find any
primitives to tests. the revised mats (along with a few others) now
check to make sure at least one identifier has the information they
look for. the removed mat was checking for library information that
is now compiled in, so the mat is now unnecessary. the others were
(not) doing argument-error checks. fixing these turned up a handful of
problems that have also been fixed: a couple of unbound variables in the
mat driver, two broken primdata declarations, a tardy argument check
by profile-load-data, and a bug in char-ready?, which was requiring
an argument rather than defaulting it to the current input port.
primdata.ss, pdhtml.ss, io.ms,
primdvars.ms, 4.ms, 6.ms, misc.ms, patch*
- added initial support for recording coverage information. when the
new parameter generate-covin-files is set, the compiler generates
.covin files containing the universe of all source objects for which
profile forms are present in the expander output. when profiling
and generation of covin files are enabled in the 's' directory, the
mats optionally generate .covout files for each mat file giving
the subset of the universe covered by the mat file, along with an
all.covout in each mat output directory aggregating the coverage
for the directory and another all.covout in the top-level mat
directory aggregating the coverage for all directories.
back.ss, compile.ss, cprep.ss, primdata.ss, s/Mf-base,
mat.ss, mats/Mf-base, mats/primvars.ms
- support for generating covout files is now built in. with-coverage-output
gathers and dumps coverage information, and aggregate-coverage-output
combines (aggregates) covout files.
pdhtml.ss, primdata.ss, compile.ss,
mat.ss, mats/Mf-base, primvars.ms
- profile-clear now adjusts active coverage trackers to avoid losing
coverage information.
pdhtml.ss,
prim5.c
- nested with-coverage calls are now supported.
pdhtml.ss
- switched to a more compact representation for covin and covout files;
reduces disk space (compressed or not) by about a factor of four
and read time by about a factor of two with no increase in write time.
primdata.ss, pdhtml.ss, cprep.ss, compile.ss,
mat.ss, mats/Mf-base
- added support for determining coverage for an entire run, including
coverage for expressions hit during boot time. 'all' mats now produce
run.covout files in each output directory, and 'allx' mats produce
an aggregate run.covout file in the mat directory.
pdhtml.ss,
mat.ss, mats/Mf-base
- profile-release-counters now adjusts active coverage trackers to
account for the counters that have been released.
pdhtml.ss,
prim5.c
- replaced the artificial "examples" target with a real "build-examples"
target so make won't think it always has to mats that depend upon
the examples directory having been compiled. mats make clean now
runs make clean in the examples directory.
mats/Mf-base
importing a library from an object file now just visits the object
file rather than doing a full load so that the run-time code for
the library is not retained. The run-time code is still read
because the current fasl format forces the entire file to be read,
but not retaining the code can lower heap size and garbage-collection
cost, particularly when many object-code libraries are imported.
The downside is that the file must be revisited if the run-time
code turns out to be required. This change exposed several
places where the code was failing to check if a revisit is needed.
syntax.ss,
7.ms, 8.ms, misc.ms, root-experr*
- fixed typos: was passing unquoted load rather than quoted load
to $load-library along one path (where it is loading source code
and therefore irrelevant), and was reporting src-path rather than
obj-path in a message about failing to define a library.
syntax.ss
- compile-file and friends now put all recompile information in
the first fasl object after the header so the library manager can
find it without loading the entire fasl file. The library manager
now does so. It also now checks to see if library object files
need to be recreated before loading them rather than loading them and
possibly recompiling them after discovering they are out of date, since
the latter requires loading the full object file even if it's out of
date, while the former takes advantage of the ability to extract just
recompile information. as well as reducing overhead, this eliminates
possibly undesirable side effects, such as creation and registration
of out-of-date nongenerative record-type descriptors. because the
library manager expects to find recompile information at the front of
an object file, it will not find all recompile information if object
files are "catted" together. also, compile-file has to hold in memory
the object code for all expressions in the file so that it can emit the
unified recompile information, rather than writing to the object file
incrementally, which can significantly increase the memory required
to compile a large file full of individual top-level forms. This does
not affect top-level programs, which were already handled as a whole,
or a typical library file that contains just a single library form.
compile.ss, syntax.ss
- the library manager now checks include files before library dependencies
when compile-imported-libraries is false (as it already did when
compile-imported-libraries is true) in case a source change affects
the set of imported libraries. (A library change can affect the set
of include files as well, but checking dependencies before include
files can cause unneeded libraries to be loaded.) The include-file
check is based on recompile-info rather than dependencies, but the
library checks are still based on dependencies.
syntax.ss
- fixed check for binding of scheme-version. (the check prevents
premature treatment of recompile-info records as Lexpand forms
to be passed to $interpret-backend.)
scheme.c
- strip-fasl-file now preserves recompile-info when compile-time info
is stripped.
strip.ss
- removed include-req* from library/ct-info and ctdesc records; it
is no longer needed now that all recompile information is maintained
separately.
expand-lang.ss, syntax.ss, compile.ss, cprep.ss, syntax.ss
- changed the fasl format and reworked a lot of code in the expander,
compiler, fasl writer, and fasl reader to allow the fasl reader
to skip past run-time information when it isn't needed and
compile-time information when it isn't needed. Skipping past
still involves reading and decoding when encrypted, but the fasl
reader no longer parses or allocates code and data in the portions
to be skipped. Side effects of associating record uids with rtds
are also avoided, as are the side effects of interning symbols
present only in the skipped data. Skipping past code objects
also reduces or eliminates the need to synchronize data and
instruction caches. Since the fasl reader no longer returns
compile-time (visit) or run-time (revisit) code and data when not
needed, the fasl reader no longer wraps these objects in a pair
with a 0 or 1 visit or revisit marker. To support this change,
the fasl writer generates separate top-level fasl entries (and
graphs) for separate forms in the same top-level source form
(e.g., begin or library). This reliably breaks eq-ness of shared
structure across these forms, which was previously broken only
when visit or revisit code was loaded at different times (this
is an incompatible change). Because of the change, fasl "groups"
are no longer needed, so they are no longer handled.
7.ss, cmacros.ss, compile.ss, expand-lang.ss, strip.ss,
externs.h, fasl.c, scheme.c,
hash.ms
- the change above is surfaced in an optional fasl-read "situation"
argument (visit, revisit, or load). The default is load. visit
causes it to skip past revisit code and data; revisit causes it
to skip past visit code and data; and load causes it not to skip
past either. visit-revisit data produced by (eval-when (visit
revisit) ---) is never skipped.
7.ss, primdata.ss,
io.stex
- to improve compile-time and run-time error checking, the
Lexpand recompile-info, library/rt-info, library-ct-info, and
program-info forms have been replaced with list-structured forms,
e.g., (recompile-info ,rcinfo).
expand-lang.ss, compile.ss, cprep.ss, interpret.ss, syntax.ss
- added visit-compiled-from-port and revisit-compiled-from-port
to complement the existing load-compiled-from-port.
7.ss, primdata.ss,
7.ms,
system.stex
- increased amount read when seeking an lz4-encrypted input
file from 32 to 1024 bytes at a time
compress-io.c
- replaced the fasl a? parameter value #t with an "all" flag value
so it's value is consistently a mask.
cmacros.ss, fasl.ss, compile.ss
- split off profile mats into a separate file
misc.ms, profile.ms (new), root-experr*, mats/Mf-base
- added coverage percent computations to mat allx/bullyx output
mat.ss, mats/Mf-base, primvars.ms
- replaced coverage tables with more generic and generally useful
source tables, which map source objects to arbitrary values.
pdhtml.ss, compile.ss, cprep.ss, primdata.ss,
mat.ss, mats/Mf-base, primvars.ms, profile.ms,
syntax.stex
- reduced profile counting overhead by using calls to fold-left
instead of calls to apply and map and by using fixnum operations
for profile counts on 64-bit machines.
pdhtml.ss
- used a critical section to fix a race condition in the calculations
of profile counts that sometimes resulted in bogus (including
negative) counts, especially when the 's' directory is profiled.
pdhtml.ss
- added discard flag to declaration for hashtable-size
primdata.ss
- redesigned the printed representation of source tables and rewrote
get-source-table! to read and store incrementally to reduce memory
overhead.
compile.ss
- added generate-covin-files to the set of parameters preserved
by compile-file, etc.
compile.ss,
system.stex
- moved covop argument before the undocumented machine and hostop
arguments to compile-port and compile-to-port. removed the
undocumented ofn argument from compile-to-port; using
(port-name ip) instead.
compile.ss, primdata.ss,
7.ms,
system.stex
- compile-port now tries to come up with a file position to supply
to make-read, which it can do if the port's positions are character
positions (presently string ports) or if the port is positioned
at zero.
compile.ss
- audited the argument-type-error fuzz mat exceptions and fixed a
host of problems this turned up (entries follow). added #f as
an invalid argument for every type for which #f is indeed invalid
to catch places where the maybe- prefix was missing on the argument
type. the mat tries hard to determine if the condition raised
(if any) as the result of an invalid argument is appropriate and
redirects the remainder to the mat-output (.mo) file prefixed
with 'Expected error', causing them to show up in the expected
error output so developers will be encouraged to audit them in
the future.
primvars.ms, mat.ss
- added an initial symbol? test on machine type names so we produce
an invalid machine type error message rather than something
confusing like "machine type #f is not supported".
compile.ss
- fixed declarations for many primitives that were specified as
accepting arguments of more general types than they actually
accept, such as number -> real for various numeric operations,
symbol -> endianness for various bytevector operations,
time -> time-utc for time-utc->date, and list -> list-of-string-pairs
for default-library-search-handler. also replaced some of the
sub-xxxx types with specific types such as sub-symbol -> endianness
in utf16->string, but only where they were causing issues with
the primvars argument-type-error fuzz mat. (this should be done
more generally.)
primdata.ss
- fixed incorrect who arguments (was map instead of fold-right,
current-date instead of time-utc->date); switched to using
define-who/set-who! generally.
4.ss, date.ss
- append! now checks all arguments before any mutation
5_2.ss
- with-source-path now properly supplies itself as who for the
string? argument check; callers like load now do their own checks.
7.ss
- added missing integer? check to $fold-bytevector-native-ref whose
lack could have resulted in a compile-time error.
cp0.ss
- fixed typo in output-port-buffer-mode error message
io.ss
- fixed who argument (was fx< rather than fx<?)
library.ss
- fixed declaration of first source-file-descriptor argument (was
sfd, now string)
primdata.ss
- added missing article 'a' in a few error messages
prims.ss
- fixed the copy-environment argument-type error message for the list
of symbols argument.
syntax.ss
- the environment procedure now catches exceptions that occur and
reraises the exception with itself as who if the condition isn't
already a who condition.
syntax.ss
- updated experr and allx patch files for changes to argument-count
fuzz mat and fixes for problems turned up by them.
root-experr*, patch*
- fixed a couple of issues setting port sizes: string and bytevector
output port put handlers don't need room to store the character
or byte, so they now set the size to the buffer length rather
than one less. binary-file-port-clear-output now sets the index
rather than size to zero; setting the size to zero is inappropriate
for some types of ports and could result in loss of buffering and
even suppression of future output. removed a couple of redundant
sets of the size that occur immediately after setting the buffer.
io.ss
- it is now possible to return from a call to with-profile-tracker
multiple times and not double-count (or worse) any counts.
pdhtml.ss, profile.ms
- read-token now requires a file position when it is handed a
source-file descriptor (since the source-file descriptor isn't
otherwise useful), and the source-file descriptor argument can
no longer be #f. the input file position plays the same role as
the input file position in get-datum/annotations. these extra
read-token arguments are now documented.
read.ss,
6.ms,
io.stex
- the source-file descriptor argument to get-datum/annotations can
no longer be #f. it was already documented that way.
read.ss
- read-token and do-read now look for the character-positions port
flag before asking if the port has port-position, since the latter
is slightly more expensive.
read.ss
- rd-error now reports the current port position if it can be determined
when fp isn't already set, i.e., when reading from a port without
character positions (presently any non string port) and fp has not
been passed in explicitly (to read-token or get-datum/annotations).
the port position might not be a character position, but it should be
better than nothing.
read.ss
- added comment noting an invariant for s_profile_release_counters.
prim5.c
- restored accidentally dropped fasl-write formdef and dropped
duplicate fasl-read formdef
io.stex
- added a 'coverage' target that tests the coverage of the Scheme-code
portions of Chez Scheme by the mats.
Makefile.in, Makefile-workarea.in
- added .PHONY declarations for all of the targets in the top-level
and workarea make files, and renamed the create-bintar, create-rpm,
and create-pkg targets bintar, rpm, and pkg.
Makefile.in, Makefile-workarea.in
- added missing --retain-static-relocation command-line argument and
updated the date
scheme.1.in
- removed a few redundant conditional variable settings
configure
- fixed declaration of condition wait (timeout -> maybe-timeout)
primdata.ss
original commit: 88501743001393fa82e89c90da9185fc0086fbcb
1266 lines
36 KiB
C
1266 lines
36 KiB
C
/* scheme.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"
|
|
#include "config.h"
|
|
#include <setjmp.h>
|
|
#include <limits.h>
|
|
#ifdef WIN32
|
|
#include <time.h>
|
|
#else
|
|
#include <sys/time.h>
|
|
#endif
|
|
#include <stddef.h>
|
|
|
|
static INT boot_count;
|
|
static IBOOL verbose;
|
|
|
|
typedef enum { UNINITIALIZED, BOOTING, RUNNING, DEINITIALIZED } heap_state;
|
|
static heap_state current_state = UNINITIALIZED;
|
|
|
|
/***************************************************************************/
|
|
/* INITIALIZATION SUPPORT */
|
|
|
|
/* locally defined functions */
|
|
static void main_init PROTO((void));
|
|
static void idiot_checks PROTO((void));
|
|
static INT run_script PROTO((const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp));
|
|
|
|
extern void scheme_include(void);
|
|
|
|
static void main_init() {
|
|
ptr tc = get_thread_context();
|
|
ptr p;
|
|
INT i;
|
|
|
|
/* create dependency for linker */
|
|
scheme_statics();
|
|
|
|
/* force thread inline allocation to go through find_room until ready */
|
|
AP(tc) = (ptr)0;
|
|
EAP(tc) = (ptr)0;
|
|
REAL_EAP(tc) = (ptr)0;
|
|
/* set up dummy CP so locking in read/write/Scall won't choke */
|
|
CP(tc) = Svoid;
|
|
CODERANGESTOFLUSH(tc) = Snil;
|
|
|
|
if (S_boot_time) S_G.protect_next = 0;
|
|
|
|
S_segment_init();
|
|
S_alloc_init();
|
|
S_thread_init();
|
|
S_intern_init();
|
|
S_gc_init();
|
|
S_number_init();
|
|
S_schsig_init();
|
|
S_new_io_init();
|
|
S_print_init();
|
|
S_stats_init();
|
|
S_foreign_init();
|
|
S_prim_init();
|
|
S_prim5_init();
|
|
S_fasl_init();
|
|
S_machine_init();
|
|
S_flushcache_init(); /* must come after S_machine_init(); */
|
|
#ifdef FEATURE_EXPEDITOR
|
|
S_expeditor_init();
|
|
#endif /* FEATURE_EXPEDITOR */
|
|
|
|
if (!S_boot_time) return;
|
|
|
|
S_protect(&S_G.profile_counters);
|
|
S_G.profile_counters = Snil;
|
|
|
|
FXLENGTHBV(tc) = p = S_bytevector(256);
|
|
for (i = 0; i < 256; i += 1) {
|
|
BVIT(p, i) =
|
|
(iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 :
|
|
i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0);
|
|
}
|
|
|
|
FXFIRSTBITSETBV(tc) = p = S_bytevector(256);
|
|
for (i = 0; i < 256; i += 1) {
|
|
BVIT(p, i) =
|
|
(iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 :
|
|
i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0);
|
|
}
|
|
|
|
NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector();
|
|
NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector();
|
|
NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector();
|
|
NULLIMMUTABLESTRING(tc) = S_null_immutable_string();
|
|
|
|
PARAMETERS(tc) = S_G.null_vector;
|
|
for (i = 0 ; i < virtual_register_count ; i += 1) {
|
|
VIRTREG(tc, i) = FIX(0);
|
|
}
|
|
|
|
p = S_code(tc, type_code, size_rp_header);
|
|
CODERELOC(p) = S_relocation_table(0);
|
|
CODENAME(p) = Sfalse;
|
|
CODEARITYMASK(p) = FIX(0);
|
|
CODEFREE(p) = 0;
|
|
CODEINFO(p) = Sfalse;
|
|
CODEPINFOS(p) = Snil;
|
|
RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0;
|
|
RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0;
|
|
RPHEADERTOPLINK(&CODEIT(p, 0)) =
|
|
(uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p;
|
|
S_protect(&S_G.dummy_code_object);
|
|
S_G.dummy_code_object = p;
|
|
|
|
S_protect(&S_G.error_invoke_code_object);
|
|
S_G.error_invoke_code_object = Snil;
|
|
S_protect(&S_G.invoke_code_object);
|
|
S_G.invoke_code_object = Snil;
|
|
|
|
S_protect(&S_G.active_threads_id);
|
|
S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads");
|
|
S_set_symbol_value(S_G.active_threads_id, FIX(0));
|
|
|
|
S_protect(&S_G.heap_reserve_ratio_id);
|
|
S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio");
|
|
SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio));
|
|
|
|
S_protect(&S_G.scheme_version_id);
|
|
S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version");
|
|
S_protect(&S_G.make_load_binary_id);
|
|
S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary");
|
|
S_protect(&S_G.load_binary);
|
|
S_G.load_binary = Sfalse;
|
|
}
|
|
|
|
static ptr fixtest = FIX(-1);
|
|
|
|
static void idiot_checks() {
|
|
IBOOL oops = 0;
|
|
|
|
if (bytes_per_segment < S_pagesize) {
|
|
fprintf(stderr, "bytes_per_segment (%x) < S_pagesize (%lx)\n",
|
|
bytes_per_segment, (long)S_pagesize);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(iptr) != sizeof(ptr)) {
|
|
fprintf(stderr, "sizeof(iptr) [%ld] != sizeof(ptr) [%ld]\n",
|
|
(long)sizeof(iptr), (long)sizeof(ptr));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(uptr) != sizeof(ptr)) {
|
|
fprintf(stderr, "sizeof(uptr) [%ld] != sizeof(ptr) [%ld]\n",
|
|
(long)sizeof(uptr), (long)sizeof(ptr));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(ptr) * 8 != ptr_bits) {
|
|
fprintf(stderr, "sizeof(ptr) * 8 [%ld] != ptr_bits [%d]\n",
|
|
(long)sizeof(ptr), ptr_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(int) * 8 != int_bits) {
|
|
fprintf(stderr, "sizeof(int) * 8 [%ld] != int_bits [%d]\n",
|
|
(long)sizeof(int), int_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(short) * 8 != short_bits) {
|
|
fprintf(stderr, "sizeof(short) * 8 [%ld] != short_bits [%d]\n",
|
|
(long)sizeof(short), short_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(long) * 8 != long_bits) {
|
|
fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n",
|
|
(long)sizeof(long), long_bits);
|
|
oops = 1;
|
|
}
|
|
#ifndef WIN32
|
|
if (sizeof(long long) * 8 != long_long_bits) {
|
|
fprintf(stderr, "sizeof(long long) * 8 [%ld] != long_long_bits [%d]\n",
|
|
(long)sizeof(long long), long_long_bits);
|
|
oops = 1;
|
|
}
|
|
#endif
|
|
if (sizeof(wchar_t) * 8 != wchar_bits) {
|
|
fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n",
|
|
(long)sizeof(wchar_t), wchar_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(size_t) * 8 != size_t_bits) {
|
|
fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n",
|
|
(long)sizeof(size_t), size_t_bits);
|
|
oops = 1;
|
|
}
|
|
#ifndef WIN32
|
|
if (sizeof(ssize_t) * 8 != size_t_bits) {
|
|
fprintf(stderr, "sizeof(ssize_t) * 8 [%ld] != size_t_bits [%d]\n",
|
|
(long)sizeof(ssize_t), size_t_bits);
|
|
oops = 1;
|
|
}
|
|
#endif
|
|
if (sizeof(ptrdiff_t) * 8 != ptrdiff_t_bits) {
|
|
fprintf(stderr, "sizeof(ptrdiff_t) * 8 [%ld] != ptrdiff_t_bits [%d]\n",
|
|
(long)sizeof(ptrdiff_t), ptrdiff_t_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(time_t) * 8 != time_t_bits) {
|
|
fprintf(stderr, "sizeof(time_t) * 8 [%ld] != time_t_bits [%d]\n",
|
|
(long)sizeof(time_t), time_t_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(bigit) * 8 != bigit_bits) {
|
|
fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n",
|
|
(long)sizeof(bigit), bigit_bits);
|
|
oops = 1;
|
|
}
|
|
if (sizeof(bigitbigit) != 2 * sizeof(bigit)) {
|
|
fprintf(stderr, "sizeof(bigitbigit) [%ld] != sizeof(bigit) [%ld] * 2\n",
|
|
(long)sizeof(bigitbigit), (long)sizeof(bigit));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(char) != 1) {
|
|
fprintf(stderr, "sizeof(char) [%ld] != 1\n", (long)sizeof(char));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(I8) != 1) {
|
|
fprintf(stderr, "sizeof(I8) [%ld] != 1\n", (long)sizeof(I8));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(U8) != 1) {
|
|
fprintf(stderr, "sizeof(U8) [%ld] != 1\n", (long)sizeof(U8));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(I16) != 2) {
|
|
fprintf(stderr, "sizeof(I16) [%ld] != 2\n", (long)sizeof(I16));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(U16) != 2) {
|
|
fprintf(stderr, "sizeof(U16) [%ld] != 2\n", (long)sizeof(U16));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(I32) != 4) {
|
|
fprintf(stderr, "sizeof(I32) [%ld] != 4\n", (long)sizeof(I32));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(U32) != 4) {
|
|
fprintf(stderr, "sizeof(U32) [%ld] != 4\n", (long)sizeof(U32));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(I64) != 8) {
|
|
fprintf(stderr, "sizeof(I64) [%ld] != 8\n", (long)sizeof(I64));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(U64) != 8) {
|
|
fprintf(stderr, "sizeof(U64) [%ld] != 8\n", (long)sizeof(U64));
|
|
oops = 1;
|
|
}
|
|
if (sizeof(string_char) != string_char_bytes) {
|
|
fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes);
|
|
oops = 1;
|
|
}
|
|
if (UNFIX(fixtest) != -1) {
|
|
fprintf(stderr, "UNFIX operation failed\n");
|
|
oops = 1;
|
|
}
|
|
if (strlen(VERSION)+1 > HEAP_VERSION_LENGTH) {
|
|
fprintf(stderr, "insufficient space for version in heap header\n");
|
|
oops = 1;
|
|
}
|
|
if (strlen(MACHINE_TYPE)+1 > HEAP_MACHID_LENGTH) {
|
|
fprintf(stderr, "insufficient space for machine id in heap header\n");
|
|
oops = 1;
|
|
}
|
|
#define big 0
|
|
#define little 1
|
|
if (native_endianness == big) {
|
|
uptr x[1];
|
|
*x = 1;
|
|
if (*(char *)x != 0) {
|
|
fprintf(stderr, "endianness claimed to be big, appears to be little\n");
|
|
oops = 1;
|
|
}
|
|
} else {
|
|
uptr x[1];
|
|
*x = 1;
|
|
if (*(char *)x == 0) {
|
|
fprintf(stderr, "endianness claimed to be little, appears to be big\n");
|
|
oops = 1;
|
|
}
|
|
}
|
|
|
|
if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) {
|
|
/* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */
|
|
fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n");
|
|
oops = 1;
|
|
}
|
|
|
|
if ((cards_per_segment & (sizeof(iptr) - 1)) != 0) {
|
|
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
|
|
fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n");
|
|
oops = 1;
|
|
}
|
|
if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) {
|
|
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
|
|
fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n");
|
|
oops = 1;
|
|
}
|
|
if (!Sfixnump(type_vector | ~mask_vector)) {
|
|
/* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */
|
|
fprintf(stderr, "vector type/length field does not look like a fixnum\n");
|
|
oops = 1;
|
|
}
|
|
|
|
if (oops) S_abnormal_exit();
|
|
}
|
|
|
|
/***************************************************************************/
|
|
/* SUPPORT FOR CALLING INTO SCHEME */
|
|
|
|
/* locally defined functions */
|
|
static ptr boot_call PROTO((ptr tc, ptr p, INT n));
|
|
static void check_ap PROTO((ptr tc));
|
|
|
|
/* arguments and ac0 set up */
|
|
static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
|
|
AC1(tc) = p;
|
|
CP(tc) = Svoid; /* don't have calling code object */
|
|
|
|
AC0(tc) = (ptr)(uptr)n;
|
|
S_call_help(tc, 0, 0);
|
|
check_ap(tc);
|
|
|
|
CP(tc) = Svoid; /* leave clean so direct Scall won't choke */
|
|
|
|
switch ((iptr)AC1(tc)) {
|
|
case 1:
|
|
p = AC0(tc);
|
|
break;
|
|
case 0:
|
|
p = Svoid;
|
|
break;
|
|
default:
|
|
p = S_get_scheme_arg(tc, 1);
|
|
break;
|
|
}
|
|
return p;
|
|
}
|
|
|
|
static void check_ap(tc) ptr tc; {
|
|
if ((uptr)AP(tc) & (byte_alignment - 1)) {
|
|
(void) fprintf(stderr, "ap is not double word aligned\n");
|
|
S_abnormal_exit();
|
|
}
|
|
if ((ptr *)AP(tc) > (ptr *)EAP(tc)) {
|
|
(void) fprintf(stderr, "ap is greater than eap\n");
|
|
S_abnormal_exit();
|
|
}
|
|
}
|
|
|
|
void S_generic_invoke(tc, code) ptr tc; ptr code; {
|
|
#if defined(PPCAIX)
|
|
struct {caddr_t entry, toc, static_link;} hdr;
|
|
hdr.entry = (caddr_t)&CODEIT(code,0);
|
|
hdr.toc = (caddr_t)0;
|
|
hdr.static_link = (caddr_t)0;
|
|
(*((void (*) PROTO((ptr)))(void *)&hdr))(tc);
|
|
#elif defined(PPCNT)
|
|
/* under NT, function headers contain no static link */
|
|
struct {I32 entry, toc;} hdr;
|
|
typedef void (*ugly)(ptr);
|
|
ugly p;
|
|
hdr.entry = (I32)&CODEIT(code,0);
|
|
hdr.toc = (I32)0;
|
|
/* MSVC++ bombs with internal compiler error if we don't split this up */
|
|
p = (ugly)&hdr;
|
|
p(tc);
|
|
#elif defined(PARISC)
|
|
struct {I32 entry, env;} hdr;
|
|
typedef void (*ugly)(ptr);
|
|
ugly p;
|
|
hdr.entry = (I32)&CODEIT(code,0);
|
|
hdr.env = (I32)0;
|
|
p = (ugly)((I32)&hdr + 2);
|
|
p(tc);
|
|
#elif defined(WIN32) && !defined(__MINGW32__)
|
|
__try {
|
|
(*((void (*) PROTO((ptr)))(void *)&CODEIT(code,0)))(tc);
|
|
}
|
|
__except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ?
|
|
EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH)
|
|
{
|
|
if (S_pants_down)
|
|
S_error_abort("nonrecoverable invalid memory reference");
|
|
else
|
|
S_error_reset("invalid memory reference");
|
|
}
|
|
#else
|
|
(*((void (*) PROTO((ptr)))(void *)&CODEIT(code,0)))(tc);
|
|
#endif
|
|
}
|
|
|
|
/***************************************************************************/
|
|
/* MISCELLANEOUS HELPERS */
|
|
|
|
/* locally defined functions */
|
|
static IBOOL next_path PROTO((char *path, const char *name, const char *ext, const char **sp, const char **dsp));
|
|
static const char *path_last PROTO((const char *path));
|
|
static char *get_defaultheapdirs PROTO((void));
|
|
|
|
static const char *path_last(p) const char *p; {
|
|
const char *s;
|
|
#ifdef WIN32
|
|
char c;
|
|
|
|
if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
|
|
if (*(p + 1) == ':')
|
|
p += 2;
|
|
#endif
|
|
|
|
for (s = p; *s != 0; s += 1)
|
|
if (DIRMARKERP(*s)) p = ++s;
|
|
return p;
|
|
}
|
|
|
|
#ifdef WIN32
|
|
#ifndef DEFAULT_HEAP_PATH
|
|
/* by default, look in executable directory or in parallel boot directory */
|
|
#define DEFAULT_HEAP_PATH "%x;%x\\..\\..\\boot\\%m"
|
|
#endif
|
|
#define SEARCHPATHSEP ';'
|
|
#define PATHSEP '\\'
|
|
|
|
static char *get_defaultheapdirs() {
|
|
char *result;
|
|
wchar_t buf[PATH_MAX];
|
|
DWORD len = sizeof(buf);
|
|
if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len))
|
|
return DEFAULT_HEAP_PATH;
|
|
else if ((result = Swide_to_utf8(buf)))
|
|
return result;
|
|
else
|
|
return DEFAULT_HEAP_PATH;
|
|
}
|
|
#else /* not WIN32: */
|
|
#define SEARCHPATHSEP ':'
|
|
#define PATHSEP '/'
|
|
#ifndef DEFAULT_HEAP_PATH
|
|
#define DEFAULT_HEAP_PATH "/usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m"
|
|
#endif
|
|
|
|
static char *get_defaultheapdirs() {
|
|
return DEFAULT_HEAP_PATH;
|
|
}
|
|
#endif /* WIN32 */
|
|
|
|
/* next_path isolates the next entry in the two-part search path sp/dsp,
|
|
* leaving the full path with name affixed in path and *sp / *dsp pointing
|
|
* past the current entry. it returns 1 on success and 0 if at the end of
|
|
* the search path. path should be a pointer to an unoccupied buffer
|
|
* PATH_MAX characters long. either or both of sp/dsp may be empty,
|
|
* but neither may be null, i.e., (char *)0. */
|
|
static IBOOL next_path(path, name, ext, sp, dsp) char *path; const char *name, *ext, **sp, **dsp; {
|
|
char *p;
|
|
const char *s, *t;
|
|
|
|
#define setp(c) if (p >= path + PATH_MAX) { fprintf(stderr, "search path entry too long\n"); S_abnormal_exit(); } else *p++ = (c)
|
|
for (;;) {
|
|
s = *sp;
|
|
p = path;
|
|
/* copy first searchpath entry into path, substituting MACHINE_TYPE for %m,
|
|
* VERSION for %v, % for %%, and : (; windows) for %: (%; windows) */
|
|
while (*s != 0 && *s != SEARCHPATHSEP) {
|
|
switch (*s) {
|
|
case '%':
|
|
s += 1;
|
|
switch (*s) {
|
|
#ifdef WIN32
|
|
case 'x': {
|
|
wchar_t exepath[PATH_MAX]; DWORD n;
|
|
s += 1;
|
|
n = GetModuleFileNameW(NULL, exepath, PATH_MAX);
|
|
if (n == 0 || (n == PATH_MAX && GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {
|
|
fprintf(stderr, "warning: executable path is too long; ignoring %%x\n");
|
|
} else {
|
|
char *tstart;
|
|
const char *tend;
|
|
tstart = Swide_to_utf8(exepath);
|
|
t = tstart;
|
|
tend = path_last(t);
|
|
if (tend != t) tend -= 1; /* back up to directory separator */
|
|
while (t != tend) setp(*t++);
|
|
free(tstart);
|
|
}
|
|
break;
|
|
}
|
|
#endif
|
|
case 'm':
|
|
s += 1;
|
|
t = MACHINE_TYPE;
|
|
while (*t != 0) setp(*t++);
|
|
break;
|
|
case 'v':
|
|
s += 1;
|
|
t = VERSION;
|
|
while (*t != 0) setp(*t++);
|
|
break;
|
|
case '%':
|
|
case SEARCHPATHSEP:
|
|
setp(*s++);
|
|
break;
|
|
default:
|
|
fprintf(stderr, "warning: ignoring extra %% in search path\n");
|
|
break;
|
|
}
|
|
break;
|
|
default:
|
|
setp(*s++);
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* unless entry was null, append name and ext onto path and return true with
|
|
* updated path, sp, and possibly dsp */
|
|
if (s != *sp) {
|
|
if ((p > path) && !DIRMARKERP(*(p - 1))) { setp(PATHSEP); }
|
|
t = name;
|
|
while (*t != 0) setp(*t++);
|
|
t = ext;
|
|
while (*t != 0) setp(*t++);
|
|
setp(0);
|
|
*sp = s;
|
|
return 1;
|
|
}
|
|
|
|
/* if current segment is empty, move to next segment. if next segment
|
|
* is empty, return false */
|
|
if (*s == 0) {
|
|
if (*(*sp = *dsp) == 0) return 0;
|
|
*dsp = "";
|
|
} else {
|
|
*sp = s + 1;
|
|
}
|
|
}
|
|
#undef setp
|
|
}
|
|
|
|
/***************************************************************************/
|
|
/* BOOT FILES */
|
|
|
|
typedef struct {
|
|
glzFile file;
|
|
char path[PATH_MAX];
|
|
} boot_desc;
|
|
|
|
#define MAX_BOOT_FILES 10
|
|
static boot_desc bd[MAX_BOOT_FILES];
|
|
|
|
/* locally defined functions */
|
|
static uptr zget_uptr PROTO((glzFile file, uptr *pn));
|
|
static INT zgetstr PROTO((glzFile file, char *s, iptr max));
|
|
static IBOOL find_boot PROTO((const char *name, const char *ext, int fd, IBOOL errorp));
|
|
static void load PROTO((ptr tc, iptr n, IBOOL base));
|
|
static void check_boot_file_state PROTO((const char *who));
|
|
|
|
static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IBOOL errorp; {
|
|
char pathbuf[PATH_MAX], buf[PATH_MAX];
|
|
uptr n; INT c;
|
|
const char *path;
|
|
#ifdef WIN32
|
|
wchar_t *expandedpath;
|
|
#else
|
|
char *expandedpath;
|
|
#endif
|
|
glzFile file;
|
|
|
|
if ((fd != -1) || S_fixedpathp(name)) {
|
|
if (strlen(name) >= PATH_MAX) {
|
|
fprintf(stderr, "boot-file path is too long %s\n", name);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
path = name;
|
|
|
|
if (fd != -1) {
|
|
file = S_glzdopen_input(fd);
|
|
} else {
|
|
#ifdef WIN32
|
|
expandedpath = S_malloc_wide_pathname(path);
|
|
file = S_glzopen_input_w(expandedpath);
|
|
#else
|
|
expandedpath = S_malloc_pathname(path);
|
|
file = S_glzopen_input(expandedpath);
|
|
#endif
|
|
/* assumption (seemingly true based on a glance at the source code):
|
|
S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
|
|
free(expandedpath);
|
|
}
|
|
|
|
if (!file) {
|
|
if (errorp) {
|
|
fprintf(stderr, "cannot open boot file %s\n", path);
|
|
S_abnormal_exit();
|
|
} else {
|
|
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
|
|
return 0;
|
|
}
|
|
}
|
|
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
|
|
|
|
/* check for magic number */
|
|
if (S_glzgetc(file) != fasl_type_header ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 'c' ||
|
|
S_glzgetc(file) != 'h' ||
|
|
S_glzgetc(file) != 'e' ||
|
|
S_glzgetc(file) != 'z') {
|
|
fprintf(stderr, "malformed fasl-object header in %s\n", path);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
/* check version */
|
|
if (zget_uptr(file, &n) != 0) {
|
|
fprintf(stderr, "unexpected end of file on %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
if (n != scheme_version) {
|
|
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
|
|
/* use separate fprintf since S_format_scheme_version returns static string */
|
|
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
/* check machine type */
|
|
if (zget_uptr(file, &n) != 0) {
|
|
fprintf(stderr, "unexpected end of file on %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
if (n != machine_type) {
|
|
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
|
|
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
} else {
|
|
const char *sp = Sschemeheapdirs;
|
|
const char *dsp = Sdefaultheapdirs;
|
|
|
|
path = pathbuf;
|
|
for (;;) {
|
|
if (!next_path(pathbuf, name, ext, &sp, &dsp)) {
|
|
if (errorp) {
|
|
fprintf(stderr, "cannot find compatible boot file %s%s in search path:\n \"%s%s\"\n",
|
|
name, ext,
|
|
Sschemeheapdirs, Sdefaultheapdirs);
|
|
S_abnormal_exit();
|
|
} else {
|
|
if (verbose) fprintf(stderr, "no compatible %s%s found\n", name, ext);
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
#ifdef WIN32
|
|
expandedpath = S_malloc_wide_pathname(path);
|
|
file = S_glzopen_input_w(expandedpath);
|
|
#else
|
|
expandedpath = S_malloc_pathname(path);
|
|
file = S_glzopen_input(expandedpath);
|
|
#endif
|
|
/* assumption (seemingly true based on a glance at the source code):
|
|
S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
|
|
free(expandedpath);
|
|
if (!file) {
|
|
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
|
|
continue;
|
|
}
|
|
|
|
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
|
|
|
|
/* check for magic number */
|
|
if (S_glzgetc(file) != fasl_type_header ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 0 ||
|
|
S_glzgetc(file) != 'c' ||
|
|
S_glzgetc(file) != 'h' ||
|
|
S_glzgetc(file) != 'e' ||
|
|
S_glzgetc(file) != 'z') {
|
|
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
|
|
S_glzclose(file);
|
|
continue;
|
|
}
|
|
|
|
/* check version */
|
|
if (zget_uptr(file, &n) != 0) {
|
|
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
|
|
S_glzclose(file);
|
|
continue;
|
|
}
|
|
|
|
if (n != scheme_version) {
|
|
if (verbose) {
|
|
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
|
|
/* use separate fprintf since S_format_scheme_version returns static string */
|
|
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
|
|
}
|
|
S_glzclose(file);
|
|
continue;
|
|
}
|
|
|
|
/* check machine type */
|
|
if (zget_uptr(file, &n) != 0) {
|
|
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
|
|
S_glzclose(file);
|
|
continue;
|
|
}
|
|
|
|
if (n != machine_type) {
|
|
if (verbose)
|
|
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
|
|
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
|
|
S_glzclose(file);
|
|
continue;
|
|
}
|
|
|
|
break;
|
|
}
|
|
}
|
|
|
|
if (verbose) fprintf(stderr, "version and machine type check\n");
|
|
|
|
if (S_glzgetc(file) != '(') { /* ) */
|
|
fprintf(stderr, "malformed boot file %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
/* ( */
|
|
if ((c = S_glzgetc(file)) == ')') {
|
|
if (boot_count != 0) {
|
|
fprintf(stderr, "base boot file %s must come before other boot files\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
} else {
|
|
if (boot_count == 0) {
|
|
for (;;) {
|
|
S_glzungetc(c, file);
|
|
/* try to load heap or boot file this boot file requires */
|
|
if (zgetstr(file, buf, PATH_MAX) != 0) {
|
|
fprintf(stderr, "unexpected end of file on %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
if (find_boot(buf, ".boot", -1, 0)) break;
|
|
if ((c = S_glzgetc(file)) == ')') {
|
|
char *sep; char *wastebuf[8];
|
|
fprintf(stderr, "cannot find subordinate boot file ");
|
|
S_glzrewind(file);
|
|
(void) S_glzread(file, wastebuf, 8); /* magic number */
|
|
(void) zget_uptr(file, &n); /* version */
|
|
(void) zget_uptr(file, &n); /* machine type */
|
|
(void) S_glzgetc(file); /* open paren */
|
|
for (sep = ""; ; sep = "or ") {
|
|
if ((c = S_glzgetc(file)) == ')') break;
|
|
S_glzungetc(c, file);
|
|
(void) zgetstr(file, buf, PATH_MAX);
|
|
fprintf(stderr, "%s%s.boot ", sep, buf);
|
|
}
|
|
fprintf(stderr, "required by %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
}
|
|
}
|
|
|
|
/* skip to end of header */
|
|
while ((c = S_glzgetc(file)) != ')') {
|
|
if (c < 0) {
|
|
fprintf(stderr, "malformed boot file %s\n", path);
|
|
S_glzclose(file);
|
|
S_abnormal_exit();
|
|
}
|
|
}
|
|
}
|
|
|
|
if (boot_count >= MAX_BOOT_FILES) {
|
|
fprintf(stderr, "exceeded maximum number of boot files (%d)\n", MAX_BOOT_FILES);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
bd[boot_count].file = file;
|
|
strcpy(bd[boot_count].path, path);
|
|
boot_count += 1;
|
|
|
|
return 1;
|
|
}
|
|
|
|
static uptr zget_uptr(glzFile file, uptr *pn) {
|
|
uptr n, m; int c; octet k;
|
|
|
|
if ((c = S_glzgetc(file)) < 0) return -1;
|
|
k = (octet)c;
|
|
n = k >> 1;
|
|
while (k & 1) {
|
|
if ((c = S_glzgetc(file)) < 0) return -1;
|
|
k = (octet)c;
|
|
m = n << 7;
|
|
if (m >> 7 != n) return -1;
|
|
n = m | (k >> 1);
|
|
}
|
|
*pn = n;
|
|
return 0;
|
|
}
|
|
|
|
static INT zgetstr(file, s, max) glzFile file; char *s; iptr max; {
|
|
ICHAR c;
|
|
|
|
while (max-- > 0) {
|
|
if ((c = S_glzgetc(file)) < 0) return -1;
|
|
if (c == ' ' || c == ')') {
|
|
if (c == ')') S_glzungetc(c, file);
|
|
*s = 0;
|
|
return 0;
|
|
}
|
|
*s++ = c;
|
|
}
|
|
|
|
return -1;
|
|
}
|
|
|
|
static IBOOL loadecho = 0;
|
|
#define LOADSKIP 0
|
|
|
|
static int set_load_binary(iptr n) {
|
|
if (!Ssymbolp(SYMVAL(S_G.scheme_version_id))) return 0; // set by back.ss
|
|
ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
|
|
if (Sprocedurep(make_load_binary)) {
|
|
S_G.load_binary = Scall3(make_load_binary, Sstring_utf8(bd[n].path, -1), Sstring_to_symbol("load"), Sfalse);
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
|
|
ptr x; iptr i;
|
|
|
|
if (base) {
|
|
S_G.error_invoke_code_object = S_boot_read(bd[n].file, bd[n].path);
|
|
if (!Scodep(S_G.error_invoke_code_object)) {
|
|
(void) fprintf(stderr, "first object on boot file not code object\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
S_G.invoke_code_object = S_boot_read(bd[n].file, bd[n].path);
|
|
if (!Scodep(S_G.invoke_code_object)) {
|
|
(void) fprintf(stderr, "second object on boot file not code object\n");
|
|
S_abnormal_exit();
|
|
}
|
|
S_G.base_rtd = S_boot_read(bd[n].file, bd[n].path);
|
|
if (!Srecordp(S_G.base_rtd)) {
|
|
S_abnormal_exit();
|
|
}
|
|
}
|
|
|
|
i = 0;
|
|
while (i++ < LOADSKIP && S_boot_read(bd[n].file, bd[n].path) != Seof_object);
|
|
|
|
while ((x = S_boot_read(bd[n].file, bd[n].path)) != Seof_object) {
|
|
if (loadecho) {
|
|
printf("%ld: ", (long)i);
|
|
fflush(stdout);
|
|
}
|
|
if (Sprocedurep(x)) {
|
|
S_initframe(tc, 0);
|
|
x = boot_call(tc, x, 0);
|
|
} else if (Sprocedurep(S_G.load_binary) || set_load_binary(n)) {
|
|
S_initframe(tc, 1);
|
|
S_put_arg(tc, 1, x);
|
|
x = boot_call(tc, S_G.load_binary, 1);
|
|
} else if (Svectorp(x)) {
|
|
iptr j, n;
|
|
n = Svector_length(x);
|
|
for (j = 0; j < n; j += 1) {
|
|
ptr y = Svector_ref(x, j);
|
|
if (Sprocedurep(y)) {
|
|
S_initframe(tc, 0);
|
|
INITVECTIT(x, j) = boot_call(tc, y, 0);
|
|
}
|
|
}
|
|
}
|
|
if (loadecho) {
|
|
S_prin1(x);
|
|
putchar('\n');
|
|
fflush(stdout);
|
|
}
|
|
i += 1;
|
|
}
|
|
|
|
S_G.load_binary = Sfalse;
|
|
S_glzclose(bd[n].file);
|
|
}
|
|
|
|
/***************************************************************************/
|
|
/* HEAP FILES */
|
|
|
|
#ifdef DEBUG
|
|
#define debug(x) {x}
|
|
#else
|
|
#define debug(x)
|
|
#endif
|
|
|
|
#include <fcntl.h>
|
|
#include <sys/types.h>
|
|
|
|
#ifdef WIN32
|
|
#include <io.h>
|
|
#endif /* WIN32 */
|
|
|
|
#ifdef MMAP_HEAP
|
|
#include <sys/mman.h>
|
|
#endif
|
|
|
|
#ifndef O_BINARY
|
|
#define O_BINARY 0
|
|
#endif /* O_BINARY */
|
|
|
|
#define check(expr,path) {if ((INT)(expr) < 0) {perror(path); S_abnormal_exit();}}
|
|
|
|
/***************************************************************************/
|
|
/* EXPORTED ROUTINES */
|
|
|
|
const char *Skernel_version(void) {
|
|
return VERSION;
|
|
}
|
|
|
|
extern void Sset_verbose(v) INT v; {
|
|
verbose = v;
|
|
}
|
|
|
|
extern void Sretain_static_relocation(void) {
|
|
S_G.retain_static_relocation = 1;
|
|
}
|
|
|
|
#ifdef ITEST
|
|
#include "itest.c"
|
|
#endif
|
|
|
|
static void default_abnormal_exit(void) {
|
|
exit(1);
|
|
}
|
|
|
|
extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); {
|
|
S_abnormal_exit_proc = abnormal_exit ? abnormal_exit : default_abnormal_exit;
|
|
S_errors_to_console = 1;
|
|
|
|
/* set before idiot checks */
|
|
S_pagesize = GETPAGESIZE();
|
|
|
|
idiot_checks();
|
|
|
|
switch (current_state) {
|
|
case RUNNING:
|
|
fprintf(stderr, "error (Sscheme_init): call Sscheme_deinit first to terminate\n");
|
|
S_abnormal_exit();
|
|
case BOOTING:
|
|
fprintf(stderr, "error (Sscheme_init): already initialized\n");
|
|
S_abnormal_exit();
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
break;
|
|
}
|
|
current_state = BOOTING;
|
|
|
|
S_G.retain_static_relocation = 0;
|
|
S_G.enable_object_counts = 0;
|
|
|
|
boot_count = 0;
|
|
|
|
#ifdef WIN32
|
|
Sschemeheapdirs = Sgetenv("SCHEMEHEAPDIRS");
|
|
#else
|
|
Sschemeheapdirs = getenv("SCHEMEHEAPDIRS");
|
|
#endif
|
|
if (Sschemeheapdirs == (char *)0) {
|
|
Sschemeheapdirs = "";
|
|
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
|
|
} else if (*Sschemeheapdirs != 0 && Sschemeheapdirs[strlen(Sschemeheapdirs)-1] == SEARCHPATHSEP) {
|
|
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
|
|
} else {
|
|
Sdefaultheapdirs = "";
|
|
}
|
|
|
|
#ifdef PTHREADS
|
|
{
|
|
int status;
|
|
if ((status = s_thread_key_create(&S_tc_key)) != 0)
|
|
S_error_abort(strerror(status));
|
|
s_thread_setspecific(S_tc_key, S_G.thread_context);
|
|
}
|
|
#endif
|
|
|
|
#ifdef ITEST
|
|
S_boot_time = 1;
|
|
main_init();
|
|
|
|
bignum_test();
|
|
exit(0);
|
|
#endif
|
|
}
|
|
|
|
static void check_boot_file_state(const char *who) {
|
|
switch (current_state) {
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who);
|
|
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
|
|
case RUNNING:
|
|
fprintf(stderr, "error (%s): already running\n", who);
|
|
S_abnormal_exit();
|
|
case BOOTING:
|
|
break;
|
|
}
|
|
}
|
|
|
|
extern void Sregister_boot_file(name) const char *name; {
|
|
check_boot_file_state("Sregister_boot_file");
|
|
find_boot(name, "", -1, 1);
|
|
}
|
|
|
|
extern void Sregister_boot_file_fd(name, fd) const char *name; int fd; {
|
|
check_boot_file_state("Sregister_boot_file_fd");
|
|
find_boot(name, "", fd, 1);
|
|
}
|
|
|
|
extern void Sregister_heap_file(UNUSED const char *path) {
|
|
fprintf(stderr, "Sregister_heap_file: saved heap files are not presently supported\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_init) PROTO((void)); {
|
|
ptr tc = Svoid; /* initialize to make gcc happy */
|
|
ptr p;
|
|
|
|
switch (current_state) {
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
fprintf(stderr, "error (Sbuild_heap): uninitialized; call Sscheme_init first\n");
|
|
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
|
|
case RUNNING:
|
|
fprintf(stderr, "error (Sbuild_heap): already running\n");
|
|
S_abnormal_exit();
|
|
case BOOTING:
|
|
break;
|
|
}
|
|
current_state = RUNNING;
|
|
|
|
S_boot_time = 1;
|
|
|
|
if (boot_count == 0) {
|
|
const char *name;
|
|
|
|
if (!kernel) {
|
|
fprintf(stderr, "no boot file or executable name specified\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
name = path_last(kernel);
|
|
if (strlen(name) >= PATH_MAX) {
|
|
fprintf(stderr, "executable name too long: %s\n", name);
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
#ifdef WIN32
|
|
{ /* strip off trailing .exe, if any */
|
|
static char buf[PATH_MAX];
|
|
iptr n;
|
|
|
|
n = strlen(name) - 4;
|
|
if (n >= 0 && (_stricmp(name + n, ".exe") == 0)) {
|
|
strcpy(buf, name);
|
|
buf[n] = 0;
|
|
name = buf;
|
|
}
|
|
}
|
|
#endif
|
|
|
|
if (!find_boot(name, ".boot", -1, 0)) {
|
|
fprintf(stderr, "cannot find compatible %s.boot in search path\n \"%s%s\"\n",
|
|
name,
|
|
Sschemeheapdirs, Sdefaultheapdirs);
|
|
S_abnormal_exit();
|
|
}
|
|
}
|
|
|
|
if (boot_count != 0) {
|
|
INT i = 0;
|
|
|
|
main_init();
|
|
if (custom_init) custom_init();
|
|
|
|
S_threads = Snil;
|
|
S_nthreads = 0;
|
|
S_set_symbol_value(S_G.active_threads_id, FIX(0));
|
|
/* pass a parent tc of Svoid, since this call establishes the initial
|
|
* thread context and hence there is no parent thread context. */
|
|
tc = (ptr)THREADTC(S_create_thread_object("startup", tc));
|
|
#ifdef PTHREADS
|
|
s_thread_setspecific(S_tc_key, tc);
|
|
#endif
|
|
|
|
/* #scheme-init enables interrupts */
|
|
TRAP(tc) = (ptr)most_positive_fixnum;
|
|
DISABLECOUNT(tc) = Sfixnum(1);
|
|
COMPRESSFORMAT(tc) = FIX(COMPRESS_LZ4);
|
|
COMPRESSLEVEL(tc) = FIX(COMPRESS_MEDIUM);
|
|
|
|
load(tc, i++, 1);
|
|
S_boot_time = 0;
|
|
|
|
while (i < boot_count) load(tc, i++, 0);
|
|
}
|
|
|
|
if (boot_count != 0) Scompact_heap();
|
|
|
|
/* complete the initialization on the Scheme side */
|
|
p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init"));
|
|
if (!Sprocedurep(p)) {
|
|
(void) fprintf(stderr,"\n$scheme-init is not bound to a procedure\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
S_initframe(tc, 0);
|
|
(void)boot_call(tc, p, 0);
|
|
|
|
/* should be okay to invoke Scheme's error handler now */
|
|
S_errors_to_console = 0;
|
|
}
|
|
|
|
extern void Senable_expeditor(history_file) const char *history_file; {
|
|
Scall1(S_symbol_value(Sstring_to_symbol("$enable-expeditor")), Strue);
|
|
if (history_file != (const char *)0)
|
|
Scall1(S_symbol_value(Sstring_to_symbol("$expeditor-history-file")),
|
|
Sstring_utf8(history_file, -1));
|
|
}
|
|
|
|
extern INT Sscheme_start(argc, argv) INT argc; const char *argv[]; {
|
|
ptr tc = get_thread_context();
|
|
ptr arglist, p; INT i;
|
|
|
|
switch (current_state) {
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
fprintf(stderr, "error (Sscheme_start): uninitialized; call Sscheme_init and Sbuild_heap first\n");
|
|
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
|
|
case BOOTING:
|
|
fprintf(stderr, "error (Sscheme_start): no heap built yet; call Sbuild_heap first\n");
|
|
S_abnormal_exit();
|
|
case RUNNING:
|
|
break;
|
|
}
|
|
|
|
arglist = Snil;
|
|
for (i = argc - 1; i > 0; i -= 1)
|
|
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
|
|
|
|
p = S_symbol_value(S_intern((const unsigned char *)"$scheme"));
|
|
if (!Sprocedurep(p)) {
|
|
(void) fprintf(stderr,"\n$scheme is not bound to a procedure\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
S_initframe(tc, 1);
|
|
S_put_arg(tc, 1, arglist);
|
|
p = boot_call(tc, p, 1);
|
|
|
|
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
|
|
return p == Svoid ? 0 : 1;
|
|
}
|
|
|
|
static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp) {
|
|
ptr tc = get_thread_context();
|
|
ptr arglist, p; INT i;
|
|
|
|
switch (current_state) {
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init and Sbuild_heap first\n", who);
|
|
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
|
|
case BOOTING:
|
|
fprintf(stderr, "error (%s): no heap built yet; call Sbuild_heap first\n", who);
|
|
S_abnormal_exit();
|
|
case RUNNING:
|
|
break;
|
|
}
|
|
|
|
arglist = Snil;
|
|
for (i = argc - 1; i > 0; i -= 1)
|
|
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
|
|
|
|
p = S_symbol_value(S_intern((const unsigned char *)"$script"));
|
|
if (!Sprocedurep(p)) {
|
|
(void) fprintf(stderr,"\n$script is not bound to a procedure\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
S_initframe(tc, 3);
|
|
S_put_arg(tc, 1, Sboolean(programp));
|
|
S_put_arg(tc, 2, Sstring_utf8(scriptfile, -1));
|
|
S_put_arg(tc, 3, arglist);
|
|
p = boot_call(tc, p, 3);
|
|
|
|
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
|
|
return p == Svoid ? 0 : 1;
|
|
}
|
|
|
|
extern INT Sscheme_script(scriptfile, argc, argv) const char *scriptfile; INT argc; const char *argv[]; {
|
|
return run_script("Sscheme_script", scriptfile, argc, argv, 0);
|
|
}
|
|
|
|
extern INT Sscheme_program(programfile, argc, argv) const char *programfile; INT argc; const char *argv[]; {
|
|
return run_script("Sscheme_program", programfile, argc, argv, 1);
|
|
}
|
|
|
|
extern void Ssave_heap(UNUSED const char *path, UNUSED INT level) {
|
|
fprintf(stderr, "Ssave_heap: saved heap files are not presently supported\n");
|
|
S_abnormal_exit();
|
|
}
|
|
|
|
extern void Sscheme_deinit() {
|
|
ptr p, tc = get_thread_context();
|
|
|
|
switch (current_state) {
|
|
case UNINITIALIZED:
|
|
case DEINITIALIZED:
|
|
fprintf(stderr, "error (Sscheme_deinit): not yet initialized or running\n");
|
|
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
|
|
case BOOTING:
|
|
fprintf(stderr, "error (Sscheme_deinit): not yet running\n");
|
|
S_abnormal_exit();
|
|
case RUNNING:
|
|
break;
|
|
}
|
|
|
|
p = S_symbol_value(S_intern((const unsigned char *)"$close-files"));
|
|
S_initframe(tc, 0);
|
|
boot_call(tc, p, 0);
|
|
|
|
S_errors_to_console = 1;
|
|
current_state = DEINITIALIZED;
|
|
}
|