~trn/reduce-algebra

52bf8b38285f64e079383e96ceee30b294d4dd8a — Jeffrey H. Johnson 16 days ago f82bba7 + 05c87f0
Merge branch 'svn/trunk'
M csl/cslbase/Makefile.am => csl/cslbase/Makefile.am +0 -68
@@ 70,10 70,6 @@ csl_CPPFLAGS    = $(TRACE)
# This is just for flatcsl where the program is all compiled as a single
# compilation unit, so "spurious" warnings are especially bulky.
flatcsl_CPPFLAGS = $(TRACE) -Wno-unused-function
if conservative
contest_CPPFLAGS = $(TRACE)
alloctest_CPPFLAGS = $(TRACE)
endif conservative

bootstrapreduce_CPPFLAGS = $(TRACE) -DBOOTSTRAP=1 -DREDUCE_PROMPTS=1



@@ 108,8 104,6 @@ plain_wxshowmathdemo = wxshowmathdemo
plain_dyndemo = dyndemo
plain_zlibdemo = zlibdemo
plain_gctest = gctest
plain_contest = contest
plain_alloctest = alloctest
else !exeext
plain_csl = csl.unnecessary.except.on.windows
plain_flatcsl = csl.unnecessary.except.on.windows


@@ 130,8 124,6 @@ plain_wxshowmathdemo = wxshowmathdemo.unnecessary.except.on.windows
plain_dyndemo = dyndemo.unnecessary.except.on.windows
plain_zlibdemo = zlibdemo.unnecessary.except.on.windows
plain_gctest = gctest.unnecessary.except.on.windows
plain_contest = gctest.unnecessary.except.on.windows
plain_alloctest = gctest.unnecessary.except.on.windows
endif !exeext

.PHONY: $(plain_csl)


@@ 153,8 145,6 @@ endif !exeext
.PHONY: $(plain_dyndemo)
.PHONY: $(plain_zlibdemo)
.PHONY: $(plain_gctest)
.PHONY: $(plain_contest)
.PHONY: $(plain_alloctest)

.PHONY:	bootstraprecompile
.PHONY:	recompile


@@ 205,10 195,6 @@ AM_CPPFLAGS     += $(MY_CPPFLAGS)
reduce_CPPFLAGS += $(MY_CPPFLAGS)
bootstrapreduce_CPPFLAGS += $(MY_CPPFLAGS)
csl_CPPFLAGS    += $(MY_CPPFLAGS)
if conservative
contest_CPPFLAGS += $(MY_CPPFLAGS)
alloctest_CPPFLAGS += $(MY_CPPFLAGS)
endif conservative
# For at least a while I will NOT warn about unused (static) functions, because
# I have rather a lot of that that are to do with support for short floats.
flatcsl_CPPFLAGS    += $(MY_CPPFLAGS)


@@ 283,10 269,6 @@ noinst_PROGRAMS += bootstrapreduce$(EXEEXT)
check_PROGRAMS = flatcsl$(EXEEXT) fwindemo$(EXEEXT) \
	termdemo$(EXEEXT) $(foxdemotarget) \
	dyndemo$(EXEEXT) zlibdemo$(EXEEXT) $(wxdemotarget)
if conservative
noinst_PROGRAMS += contest$(EXEEXT)
check_PROGRAMS += alloctest$(EXEEXT)
endif
endif !mac_framework

if mac_framework


@@ 318,8 300,6 @@ endif !arithlib

if conservative
gc_sources = newcslgc.cpp newallocate.cpp 
contest_SOURCES = contest.cpp winsupport.cpp $(gc_sources)
alloctest_SOURCES = alloctest.cpp sysfwin.cpp $(gc_sources)
else !conservative
gc_sources = cslgc.cpp allocate.cpp 
endif !conservative


@@ 636,13 616,6 @@ zlibdemo_LDADD = -lz
remake-zlibdemo-source:	$(cslbase)/preserve.cpp
	unifdef -x2 -DZLIB_DEMO < $(cslbase)/preserve.cpp > $(cslbase)/zlibdemo.cpp

if conservative
contest_LDADD =
contest_DEPENDENCIES =
alloctest_LDADD =
alloctest_DEPENDENCIES =
endif conservative

if windows

# Even on Windows I will try to use commands "cp" and "rm", and in general


@@ 821,9 794,6 @@ reduce_CPPFLAGS += $(CRINC)
bootstrapreduce_CPPFLAGS += $(CRINC)
csl_CPPFLAGS    += $(CRINC)
flatcsl_CPPFLAGS    += $(CRINC)
if conservative
alloctest_CPPFLAGS += $(CRINC)
endif conservative

# The following ugly dependencies are here so that one can go, for
# instance, "make csl.o" in a clean tree and crlibm building will get


@@ 834,17 804,11 @@ csl_LDADD += ../lib/libcrlibm.a
flatcsl_LDADD += ../lib/libcrlibm.a
bootstrapreduce_LDADD += ../lib/libcrlibm.a
reduce_LDADD += ../lib/libcrlibm.a
if conservative
alloctest_LDADD += ../lib/libcrlibm.a
endif conservative

csl_DEPENDENCIES += $(CRLIBMDEPS)
flatcsl_DEPENDENCIES += $(CRLIBMDEPS)
bootstrapreduce_DEPENDENCIES += $(CRLIBMDEPS)
reduce_DEPENDENCIES += $(CRLIBMDEPS)
if conservative
alloctest_DEPENDENCIES += $(CRLIBMDEPS)
endif conservative

$(CRLIBMDEPS):
	@printf "About to build crlibm for %s ($@)\n" `pwd`


@@ 865,9 829,6 @@ reduce_CPPFLAGS += $(FFINC)
bootstrapreduce_CPPFLAGS += $(FFINC)
csl_CPPFLAGS    += $(FFINC)
flatcsl_CPPFLAGS    += $(FFINC)
if conservative
alloctest_CPPFLAGS    += $(FFINC)
endif

# The following ugly dependencies are here so that one can go, for
# instance, "make csl.o" in a clean tree and libffi building will get


@@ 878,17 839,11 @@ csl_LDADD += ../lib/libffi.a
flatcsl_LDADD += ../lib/libffi.a
bootstrapreduce_LDADD += ../lib/libffi.a
reduce_LDADD += ../lib/libffi.a
if conservative
alloctest_LDADD += ../lib/libffi.a
endif conservative

csl_DEPENDENCIES += $(LIBFFIDEPS)
flatcsl_DEPENDENCIES += $(LIBFFIDEPS)
bootstrapreduce_DEPENDENCIES += $(LIBFFIDEPS)
reduce_DEPENDENCIES += $(LIBFFIDEPS)
if conservative
alloctest_DEPENDENCIES += $(LIBFFIDEPS)
endif conservative

$(LIBFFIDEPS):
	@printf "About to build libffi for %s ($@)\n" `pwd`


@@ 903,9 858,6 @@ reduce_CPPFLAGS += $(SOFTFLOATINC)
bootstrapreduce_CPPFLAGS += $(SOFTFLOATINC)
csl_CPPFLAGS    += $(SOFTFLOATINC)
flatcsl_CPPFLAGS    += $(SOFTFLOATINC)
if conservative
alloctest_CPPFLAGS    += $(SOFTFLOATINC)
endif conservative

# The following ugly dependencies are here so that one can go, for
# instance, "make csl.o" in a clean tree and softfloat building will get


@@ 916,16 868,10 @@ csl_LDADD += ../lib/libsoftfloat.a
flatcsl_LDADD += ../lib/libsoftfloat.a
bootstrapreduce_LDADD += ../lib/libsoftfloat.a
reduce_LDADD += ../lib/libsoftfloat.a
if conservative
alloctest_LDADD    += ../lib/libsoftfloat.a
endif conservative

csl_DEPENDENCIES += $(SOFTFLOATDEPS)
bootstrapreduce_DEPENDENCIES += $(SOFTFLOATDEPS)
reduce_DEPENDENCIES += $(SOFTFLOATDEPS)
if conservative
alloctest_DEPENDENCIES    += $(SOFTFLOATDEPS)
endif conservative

$(SOFTFLOATDEPS):
	@printf "About to build softfloat for %s ($@)\n" `pwd`


@@ 1362,14 1308,6 @@ flatcsl$(COM):	$(flatcsl_OBJECTS) $(csl_DEPENDENCIES) $(FOXDEPS) $(WXDEPS) $(HDR
endif gui
endif windows

contest$(EXEEXT): $(contest_OBJECTS) $(contest_DEPENDENCIES)
	@printf "Relinking $@ because of $?\n"
	$(CXXLINKTO) $(DEST)contest$(EXEEXT) $(contest_OBJECTS) $(contest_LDADD) $(AM_LIBS) $(LIBS)

alloctest$(EXEEXT): $(alloctest_OBJECTS) $(alloctest_DEPENDENCIES)
	@printf "Relinking $@ because of $?\n"
	$(CXXLINKTO) $(DEST)alloctest$(EXEEXT) $(alloctest_OBJECTS) $(alloctest_LDADD) $(AM_LIBS) $(LIBS) $(WINAP)

reduce$(EXEEXT):	$(reduce_OBJECTS) $(reduce_DEPENDENCIES) $(FOXDEPS) \
			$(WXDEPS) $(generated_lisp) $(HDRS) $(REDUCECOM) $(CYG_REDUCE)
	@printf "Relinking $@ because of $?\n"


@@ 1723,12 1661,6 @@ $(plain_zlibdemo):	zlibdemo.exe
$(plain_gctest):	gctest.exe
	printf "$(MAKE) gctest.exe is preferred\n"

$(plain_contest):	contest.exe
	printf "$(MAKE) contest.exe is preferred\n"

$(plain_alloctest):	alloctest.exe
	printf "$(MAKE) alloctest.exe is preferred\n"

endif exeext

termdemo$(EXEEXT): $(termdemo_OBJECTS) $(termdemo_DEPENDENCIES)

M csl/cslbase/bytes1.cpp => csl/cslbase/bytes1.cpp +4 -3
@@ 919,12 919,13 @@ inline void do_freerstr()
inline void poll_jump_back(LispObject& A_reg)
{
#ifdef CONSERVATIVE
    poll();
#else
    static uintptr_t n = 0;
    if ((++n & 0x3f) == 0) poll();
#else // CONSERVATIVE
    if ((uintptr_t)stack >=
        ((uintptr_t)stackLimit | event_flag))
        respond_to_stack_event();
#endif
#endif // CONSERVATIVE
}

static inline LispObject do_pvbind(LispObject vals, LispObject vars)

M csl/cslbase/bytes2.cpp => csl/cslbase/bytes2.cpp +2 -2
@@ 154,12 154,12 @@ size_t xppc;
    {   err_printf("\n+++ stack overflow\n");
        return aerror("stack overflow");
    }
#else
#else // DEBUG
    if (check_stack("bytecode_interpreter",__LINE__))
    {   err_printf("\n+++ stack overflow\n");
        return aerror("stack overflow");
    }
#endif
#endif // DEBUG
#else // CHECK_STACK
    {   char *p = reinterpret_cast<char *>(&p);
        if ((uintptr_t)p < C_stacklimit)

M csl/cslbase/conservative.txt => csl/cslbase/conservative.txt +75 -0
@@ 336,3 336,78 @@ will end up reasonably close together in memory, so scanning all of them
be cheap enough. So that is my current plan. So that introduces more work in
the evacuate procedure - it must mark fields in a copied symbol head as
dirty!

===========================

While developing the consrvative GC I am also looking forward to an
experiment in support for Lisp threads. This adds a lot more fun. To achieve
this I will need to build on some thoughts that have a status that lies
somewhere between hypotheses and assumptions and requirements. I will
document them here.

If several threads synchronise using semaphores, mutexes or condition
variables I will suppose that a thread that is released will see all data
placed in memory by the thread that led to that release. And that this does
not depend on either thread using datatypes such as std::atomic<T>. The
simple cases here will be if thread A writes some data and then either
unlocks a muxed or signals a condition variable such that thread B is
able to proceed. I will suppse that thread B can observe everything that
thread A had written before it called the synchronization primitive, but that
the visibility of anything done after that is uncertain. Note that this is
a supposition applying to the C++ library synchronisation schemes and not
to any home-brew use of test-and-set associated with busy waiting etc.
Aha cppreference under its discussion of memory order sats that a lock
operation on a muxex is an "acquire" and an unlock is a "release".

For the discussion here I will suppose that all atomic operations I mention
are done using sequentially consistent memory ordering.
In addition to the above where I have data that is of the form std::atomic<T>
then changes made in one thread become visible to other threads, although
with no guarantee of whether there will be a delay. If the atomics enforce
a release-aquire behabiour then all memory operations on both atoic and
non-atomic values that happen before the changes made by the first thread
will be visible once the second thread has observed that change. Threads that
do not read from (and hence synchromize on) the atomic may or may not see
other changes. As well as hardware behaviour there is what compilers are
entitled to do. Compilers must not rearrange code so as to move other
memory accesses before or after a (suitably carefully constrained) atomic
operation. So without use of atomic<T> a "sufficiently advanced compiler"
might shuffle memory accesses to an almost arbitrary extent including
removing them totally. I think that the inter-processor consistency only
applies if the same atomic item is written by the first thread as is read by
the second.

The C++ documentation for thread_fence still indicates that one thread must
update something atomic and another must then read from it for any
synmchronization to occur. Right now I think my understanding is that they
can force ordering as between memory accesses but of themselves they do not
perform cross-thread synchronisation - explicit use of atomic variables is
needed for that. Fences may also prevent compiler re-orderings as well as
hardware re-orderings which could sometimes be visible in the absence of
full enforcement of sequential behaviour.

I believe there is a bit of a disconnect. At the architecture level the
discussions are about memory references to locations and such references may
be made with our without accompanying memory ordering constaints and
semantics. In C++ those options are only provided for explicitly atomic
items and the default access mode to those is sequentially_constistent which
is potentially one of the more expensive options. So what I will do is leave
almost all data "simple" (ie not atomic). Then if any pair of Lisp threads
need to collaborate they must take explicit steps to synchronise because
without that it is not just that there may be race conditions - some data
written by the one might just not be observed by the other. When memory is
being allocated there will be use of (some) atomic variables such that
each thread can allocate privately most of the time but when memory becomes
full all come together with careful synchronisation. If the garbage collector
is single thread it can then access the memory as used by every thread since
they are all paused and have had write-buffers etc flushed.
But I will now experiment with an operation I will call AT() which is intended
to impose explicitly atomic access to data. So if (say) v is a simple variable
then AT(v) can be used (either as an lvalue or an rvalue) to denote atomic
reference to v. And AT(v) will support the various C++ methods for read-
modify-write operations that std::atomic provides. This is not going to
adhere to C++ standards very well but may still prove useful!





M csl/cslbase/contest.cpp => csl/cslbase/contest.cpp +1 -1
@@ 228,7 228,7 @@ LispObject big_divisor, big_dividend, big_quotient, big_fake1,
           big_fake2;
LispObject active_stream, current_module;
LispObject autoload_symbol, features_symbol, lisp_package;
LispObject sys_hash_table; //@, sxhash_hash_table;
LispObject sys_hash_table, sxhash_hash_table;
LispObject help_index, cfunarg, lex_words, get_counts, fastget_names;
LispObject input_libraries, output_library, current_file,
           break_function;

M csl/cslbase/externs.h => csl/cslbase/externs.h +3 -9
@@ 231,20 231,14 @@ extern uintptr_t *C_stackbase, C_stacklimit;

extern LispObject multiplication_buffer;

#ifdef CONSERVATIVE
extern void write_barrier(atomic<LispObject> *p, LispObject q);
#if defined CONSERVATIVE && defined GENERATIONAL
extern void write_barrier(LispObject *p, LispObject q);
#else // !CONSERVATIVE
inline void write_barrier(atomic<LispObject> *p, LispObject q)
{  *p = q;
}
inline void write_barrier(LispObject *p, LispObject q)
{  *p = q;
}
#endif // !CONSERVATIVE

// This tiny function exists just so that I can set a breakpoint on it.

extern std::mutex debug_lock;
extern const char *debug_file;
extern int debug_line;


@@ 614,10 608,10 @@ extern uint64_t reclaim_trigger_count, reclaim_trigger_target;

#ifdef CONSERVATIVE
extern void reclaim(const char *why);
#else
#else // CONSERVATIVE
extern LispObject reclaim(LispObject value_to_return, const char *why,
                          int stg_class, size_t size);
#endif
#endif // CONSERVATIVE
extern void use_gchook(LispObject arg);

extern uint64_t force_cons, force_vec;

M csl/cslbase/fwin.cpp => csl/cslbase/fwin.cpp +4 -1
@@ 474,9 474,12 @@ void mac_deal_with_application_bundle(int argc, const char *argv[])
// attempt to display a report including the error code.
            std::fprintf(stderr,
                         "Returned from execv with error code %d\n", errno);
// These daya I can not even be certain that calling std::exit() will cause
// These days I can not even be certain that calling std::exit() will cause
// and application to terminate (I think) but the use here should NEVER get
// called and so just what happens here is not that important!
            std::fflush(stdout);
            std::fflush(stderr);
            if (spool_file != nullptr) std::fflush(spool_file);
            std::exit(1);
        }
    }

M csl/cslbase/headers.h => csl/cslbase/headers.h +1 -1
@@ 220,7 220,7 @@ inline double CSLpow(double x, double y)
#include "externs.h"
#ifdef CONSERVATIVE
#include "newallocate.h"
#else
#else // CONSERVATIVE
#include "allocate.h"
#endif // CONSERVATIVE
#include "syscsl.h"

M csl/cslbase/lisphash.cpp => csl/cslbase/lisphash.cpp +2 -2
@@ 132,11 132,11 @@ inline bool COMPARE(LispObject k1, LispObject k2)

// I will give myself accessors to the keys and values.

inline AtomicLispObject& ht(size_t n)
inline LispObject& ht(size_t n)
{   return elt(h_table, n);
}

inline AtomicLispObject& htv(size_t n)
inline LispObject& htv(size_t n)
{   return elt(v_table, n);
}


M csl/cslbase/log.h => csl/cslbase/log.h +19 -1
@@ 52,17 52,35 @@
#include <ctime>
#include <csignal>

#ifdef CSL

extern std::FILE *spool_file;
extern void term_close();

#endif // CSL

// An "my_assert" scheme that lets me write in my own code to print the
// diagnostics. I also "exit()" rather than "abort()" since that is slightly
// cleaner!

[[noreturn]] inline void my_abort()
{   std::exit(EXIT_FAILURE);
{   std::fflush(stdout);
    std::fflush(stderr);
#ifdef CSL
    if (spool_file != nullptr) std::fflush(spool_file);
    term_close();
#endif
    std::exit(EXIT_FAILURE);
}

[[noreturn]] inline void my_abort(const char *msg)
{   std::fprintf(stderr, "\n\n!!! Aborting: %s\n\n", msg);
    std::fflush(stdout);
    std::fflush(stderr);
#ifdef CSL
    if (spool_file != nullptr) std::fflush(spool_file);
    term_close();
#endif
    std::exit(EXIT_FAILURE);
}


M csl/cslbase/newallocate.cpp => csl/cslbase/newallocate.cpp +2 -2
@@ 800,8 800,8 @@ void garbageCollectOnBehalfOfAll()
        if (pendingCount == 0 &&
            userGcRequest == GcStyleNone) break;
        newRegionNeeded();
        releaseOtherThreads();
        return;
/////        releaseOtherThreads();
/////        return;
    }
// Here all the GC helper threads may be waiting for a Chunk to copy. There
// is not going to be one, so I can release them.

M csl/cslbase/newallocate.h => csl/cslbase/newallocate.h +15 -2
@@ 346,6 346,12 @@ extern Page *pagesPinChain;

inline Page *FdirtyPages() { return dirtyPages; }


#ifdef GENERATIONAL
// By controlling this with an #ifdef I will be able to measure how much
// overhead this imposes - and if that seems like too much I may need to
// re-think plans!

inline void write_barrier(LispObject *p, LispObject q)
{   *p = q;
// Only up-pointers can cause trouble, so if I write in something that


@@ 410,6 416,7 @@ inline void write_barrier(LispObject *p, LispObject q)
        }
    }
}
#endif // GENERATIONAL

// There will be times when I can clear an individual cell's status as
// dirty, and this function is here to do just that.


@@ 905,7 912,8 @@ inline LispObject get_n_bytes(size_t n, uintptr_t thr,
// not yet have its length field filled in. And that has to be the case
// because the region I have set aside for this Chunk may be beyond the end
// of the current Page (or the next pinned place within the Page).
        uint64_t newLimit = reinterpret_cast<uintptr_t>(newChunk) + targetChunkSize+n;
        uint64_t newLimit =
            reinterpret_cast<uintptr_t>(newChunk) + targetChunkSize+n;
// Possibly the allocation of the new chunk ran beyond the current page
// and that will be cause to consider triggering garbage collection. If the
// chunk size is 16K and the page size 8M it will take 512 chunk allocations


@@ 982,7 990,9 @@ inline LispObject get_n_bytes(size_t n, uintptr_t thr,
// so the situation when I call difficult_n_bytes() is just as if it had
// been called directly from the main program save that gFringe may have
// been incremented - possibly beyond gLimit.
    return static_cast<LispObject>(difficult_n_bytes());
    r = difficult_n_bytes();
    my_assert(is_cons(r), "difficult_n_bytes should return a CONS");
    return static_cast<LispObject>(r);
}

inline LispObject get_n_bytes(size_t n)


@@ 1325,6 1335,9 @@ inline void fitsWithinExistingGap(unsigned int i, size_t n, size_t gap)
inline void regionInPageIsFull(unsigned int i, size_t n,
                               size_t gap, unsigned int &pendingCount)
{
#ifdef DEBUG
    previousCons = 0;
#endif // DEBUG
// Here the current region in the Page is full. I may either have reached the
// very end of the page or I may have merely run up against a pinned Chunk
// within it.

M csl/cslbase/newcslgc.cpp => csl/cslbase/newcslgc.cpp +2 -1
@@ 939,7 939,8 @@ void prepareForGarbageCollection(bool major)
// it will allocate a fresh Chunk. I set myBusyChunk so that the allocation
// of the new Chunk does not mark the existing one as needing scanning.
        myBusyChunk = myChunkBase[threadId];
        if (myBusyChunk != nullptr) myBusyChunk->chunkFringe = fringe;
        if (myBusyChunk != nullptr)
            myBusyChunk->chunkFringe = static_cast<uintptr_t>(fringe);
        myChunkBase[threadId] = myBusyChunk = nullptr;
        fringe = limit[threadId];
        gc_n_bytes1(0, threadId, fringe);

M csl/cslbase/serialize.cpp => csl/cslbase/serialize.cpp +32 -32
@@ 1500,7 1500,7 @@ down:
                case SER_L_A:
                    GC_PROTECT(prev = cons(fixnum_of_int(0), nil));
                    if (c & 1) reader_repeat_new(prev);
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    pbase = prev;
                    p = reinterpret_cast<LispObject *>(vcaraddr(pbase));
                    goto down;


@@ 1509,7 1509,7 @@ down:
                case SER_L_A_S:
                    GC_PROTECT(prev = cons(b, fixnum_of_int(0)));
                    if (c & 1) reader_repeat_new(prev);
                    *(AtomicLispObject*)p = b = prev;
                    *(LispObject*)p = b = prev;
                    pbase = b;
                    p = reinterpret_cast<LispObject *>(vcdraddr(b));
                    goto down;


@@ 1525,7 1525,7 @@ down:
                    if (c & 1) reader_repeat_new(prev);
                    if (c & 2) reader_repeat_new(cdr(prev));
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    p = reinterpret_cast<LispObject *>(vcaraddr(pbase));
                    goto down;


@@ 1540,7 1540,7 @@ down:
                    if (c & 1) reader_repeat_new(prev);
                    if (c & 2) reader_repeat_new(cdr(prev));
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    setcar(pbase, b);
                    b = pbase;


@@ 1560,7 1560,7 @@ down:
                    if (c & 2) reader_repeat_new(cdr(prev));
                    if (c & 4) reader_repeat_new(cdr(cdr(prev)));
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    setcar(pbase, b);
                    b = pbase;


@@ 1581,7 1581,7 @@ down:
                    if (c & 2) reader_repeat_new(cdr(prev));
                    if (c & 4) reader_repeat_new(cdr(cdr(prev)));
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    setcar(pbase, b);
                    b = pbase;


@@ 1598,7 1598,7 @@ down:
// can be shared.
                    if (c & 1) reader_repeat_new(prev);
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    setcar(pbase, b);
                    b = pbase;


@@ 1614,7 1614,7 @@ down:
                    GC_PROTECT(prev = list4(nil, nil, nil, nil));
                    if (c & 1) reader_repeat_new(prev);
                    setcar(prev, b);
                    b = *(AtomicLispObject*)p = prev;
                    b = *(LispObject*)p = prev;
                    pbase = cdr(b);
                    setcar(pbase, b);
                    b = pbase;


@@ 1645,7 1645,7 @@ down:
// and so on using 7 bits per byte... up until I have used 8 bytes.
// If one is needed beyond that it can be a final 8-bit value.
// This allows for up to 2^64 back-references.
                    *(AtomicLispObject*)p = reader_repeat_old(1 + 64 + read_u64());
                    *(LispObject*)p = reader_repeat_old(1 + 64 + read_u64());
                    goto up;

                case SER_DUP:


@@ 1679,7 1679,7 @@ down:
// they needed to be bignums. Since they are immutable objects I do not
// believe that should cause any trouble.
                    GC_PROTECT(prev = make_lisp_unsigned64(repeat_arg));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    goto up;

                case SER_NEGFIXNUM:


@@ 1696,7 1696,7 @@ down:
                        repeat_arg_ready = true;
                    }
                    GC_PROTECT(prev = make_lisp_integer64(repeat_arg));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    goto up;

                case SER_DUPRAWSYMBOL:


@@ 1711,7 1711,7 @@ down:
                    assert(opcode_repeats == 0);
                    GC_PROTECT(prev =
                        get_basic_vector(TAG_SYMBOL, TYPE_SYMBOL, symhdr_length));
                    *(AtomicLispObject*)p = w = prev;
                    *(LispObject*)p = w = prev;
                    if (c == SER_DUPRAWSYMBOL) reader_repeat_new(prev);
// Note that the vector as created will have its LENGTH encoded in the
// header, but for symbols that is incorrect so I need to re-write the


@@ 1783,7 1783,7 @@ down:
                            GC_PROTECT(prev = Lgensym(nil, prev));
                        }
                        else GC_PROTECT(prev = iintern(boffo, (int32_t)boffop, CP, 0));
                        *(AtomicLispObject*)p = prev;
                        *(LispObject*)p = prev;
                        if (c == SER_DUPSYMBOL || c == SER_DUPGENSYM)
                            reader_repeat_new(prev);
                        goto up;


@@ 1799,7 1799,7 @@ down:
// a 32-bit single float
                    assert(opcode_repeats == 0);
                    GC_PROTECT(prev = make_boxfloat(read_f32(), TYPE_SINGLE_FLOAT));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    goto up;

                case SER_FLOAT64:


@@ 1810,7 1810,7 @@ down:
// But at present I think that will be an uncommon case with Reduce and so
// I will give priority to other cases.
                    GC_PROTECT(prev = make_boxfloat(read_f64(), TYPE_DOUBLE_FLOAT));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    goto up;

#ifdef HAVE_SOFTFLOAT


@@ 1819,7 1819,7 @@ down:
                    assert(opcode_repeats == 0);
                    GC_PROTECT(prev = make_boxfloat(0.0, TYPE_LONG_FLOAT));
                    long_float_val(prev) = read_f128();
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    goto up;
#endif // HAVE_SOFTFLOAT



@@ 1844,7 1844,7 @@ down:
                    {   repeat_arg = read_u64();
                        repeat_arg_ready = true;
                    }
                    prev = *(AtomicLispObject*)p = (static_cast<LispObject>(repeat_arg)<<(Tw+2)) | TAG_HDR_IMMED;
                    prev = *(LispObject*)p = (static_cast<LispObject>(repeat_arg)<<(Tw+2)) | TAG_HDR_IMMED;
                    goto up;

                case SER_BITVEC:


@@ 1853,7 1853,7 @@ down:
                    {   size_t len = CELL + (w + 7)/8; // length in bytes
                        GC_PROTECT(prev =
                            get_basic_vector(TAG_VECTOR, bitvechdr_(w), len));
                        *(AtomicLispObject*)p = prev;
                        *(LispObject*)p = prev;
                        char *x = reinterpret_cast<char *>(&basic_celt(prev, 0));
                        for (size_t i=0; i<(size_t)w; i++)
                            *x++ = read_data_byte();


@@ 1869,7 1869,7 @@ down:
                    opcode_repeats++;
                    c = SER_NIL;
                case SER_NIL:
                    prev = *(AtomicLispObject*)p = nil;
                    prev = *(LispObject*)p = nil;
                    goto up;

                case SER_END:


@@ 1918,7 1918,7 @@ down:
// allows for the header word as well.
                size_t n = read_u64();
                GC_PROTECT(prev = get_basic_vector(tag, type, CELL*(n+1)));
                w = *(AtomicLispObject*)p = prev;
                w = *(LispObject*)p = prev;
// Note that the "vector" just created may be tagged with TAG_NUMBERS
// rather than TAG_VECTOR, so I use the access macro "vselt" rather than
// "elt" - and that survives whichever case I am in.


@@ 1957,19 1957,19 @@ down:
// repeat-runs of "SER_BACKREF0 <1>" to reference the top item in the
// repeat heap. The efford involved in supporting SER_REPEAT to compress
// such sequences is minimal here, so I do so.
            *(AtomicLispObject*)p = reader_repeat_old(1 + (c & 0x1f));
            *(LispObject*)p = reader_repeat_old(1 + (c & 0x1f));
            goto up;

        case SER_BACKREF1:
// I do not view repeated instances of BACKREF1 as significant, but it is
// so cheap to support that I will.
            *(AtomicLispObject*)p = reader_repeat_old(1 + 32 + (c & 0x1f));
            *(LispObject*)p = reader_repeat_old(1 + 32 + (c & 0x1f));
            goto up;

        case SER_FIXNUM:
            repeat_arg = c & 0x1f;
            if ((c & 0x10) != 0) repeat_arg |= (uint64_t)~0xf; // sign extend
            *(AtomicLispObject*)p = fixnum_of_int((int64_t)repeat_arg);
            *(LispObject*)p = fixnum_of_int((int64_t)repeat_arg);
            goto up;

        case SER_STRING:


@@ 1981,7 1981,7 @@ down:
            assert(opcode_repeats == 0);
            w = (c & 0x1f) + 1;
            GC_PROTECT(prev = get_basic_vector(TAG_VECTOR, TYPE_STRING_4, CELL+w));
            *(AtomicLispObject*)p = prev;
            *(LispObject*)p = prev;
            {   char *x = reinterpret_cast<char *>(&basic_celt(prev, 0));
                for (size_t i=0; i<(size_t)w; i++) *x++ = read_string_byte();
// Fill in end of the memory block with zero bytes so it is properly tidy.


@@ 2013,7 2013,7 @@ down:
                                                   TAG_VECTOR;
                if (vector_i8(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    unsigned char *x = reinterpret_cast<unsigned char *>(start_contents(prev));
                    if (is_string_header(type))
                        for (size_t i=0; i<(size_t)w; i++)


@@ 2024,7 2024,7 @@ down:
                }
                else if (vector_i32(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+4*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    uint32_t *x = (uint32_t *)start_contents(prev);
// 32-bit integers are transmitted most significant byte first.
                    for (size_t i=0; i<(size_t)w; i++)


@@ 2037,7 2037,7 @@ down:
                }
                else if (vector_f64(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+8*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    double *x = reinterpret_cast<double *>(start_contents64(prev));
// There has to be a padder word in these objects on a 32-bit machine so
// that the data is 64-bit aligned. Clean it up.


@@ 2046,7 2046,7 @@ down:
                }
                else if (vector_i16(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+2*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    std::uint16_t *x = reinterpret_cast<std::uint16_t *>(start_contents(prev));
                    for (size_t i=0; i<(size_t)w; i++)
                    {   uint32_t q = read_data_byte() & 0xff;


@@ 2056,7 2056,7 @@ down:
                }
                else if (vector_i64(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+8*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    uint64_t *x = (uint64_t *)start_contents64(prev);
                    if (!SIXTY_FOUR_BIT) *(int32_t *)start_contents(prev) = 0;
                    for (size_t i=0; i<(size_t)w; i++)


@@ 2072,7 2072,7 @@ down:
                }
                else if (vector_f32(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+4*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    float *x = reinterpret_cast<float *>(start_contents(prev));
                    for (size_t i=0; i<(size_t)w; i++) *x++ = read_f32();
                    while (((intptr_t)x & 7) != 0) *x++ = 0;


@@ 2080,14 2080,14 @@ down:
#ifdef HAVE_SOFTFLOAT
                else if (vector_f128(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+16*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    std::fprintf(stderr, "128-bit floats not supported (yet?)\n");
                    my_abort("128-bit float");
                }
#endif // HAVE_SOFTFLOAT
                else if (vector_i128(type))
                {   GC_PROTECT(prev = get_basic_vector(tag, type, CELL+16*w));
                    *(AtomicLispObject*)p = prev;
                    *(LispObject*)p = prev;
                    std::fprintf(stderr, "128-bit integer arrays not supported (yet?)\n");
                    my_abort("128-bit integer arrays");
                }

M csl/cslbase/stream.h => csl/cslbase/stream.h +22 -30
@@ 155,69 155,61 @@ extern char memory_print_buffer[MAX_PROMPT_LENGTH];
#define STREAM_SIZE           (14*CELL)
#define BUFFERED_STREAM_SIZE  (STREAM_SIZE+STREAM_BUFFER_SIZE)

inline AtomicLispObject &stream_type(LispObject v)
inline LispObject &stream_type(LispObject v)
{   return basic_elt(v, 0);
}
inline AtomicLispObject &stream_write_data(LispObject v)
inline LispObject &stream_write_data(LispObject v)
{   return basic_elt(v, 1);
}
inline AtomicLispObject &stream_read_data(LispObject v)
inline LispObject &stream_read_data(LispObject v)
{   return basic_elt(v, 2);
}

// There are a number of things I make atomic<> here even in cases where it
// is not necessary - my hope is that they are cases that are in general not
// within critical loops.

inline atomic<std::FILE *> &stream_file(LispObject v)
{   return (atomic<std::FILE *>&)basic_elt(v, 3);
inline std::FILE *& stream_file(LispObject v)
{   return (std::FILE *&)basic_elt(v, 3);
}
inline atomic<character_stream_writer *> &stream_write_fn(
    LispObject v)
{   return (atomic<character_stream_writer *>&)basic_elt(v, 4);
inline character_stream_writer *& stream_write_fn(LispObject v)
{   return (character_stream_writer *&)basic_elt(v, 4);
}
inline atomic<other_stream_op *> &stream_write_other(LispObject v)
{   return (atomic<other_stream_op *>&)basic_elt(v,5);
inline other_stream_op *& stream_write_other(LispObject v)
{   return (other_stream_op *&)basic_elt(v,5);
}
inline AtomicLispObject &stream_line_length(LispObject v)
inline LispObject &stream_line_length(LispObject v)
{   return basic_elt(v, 6);
}
inline AtomicLispObject &stream_byte_pos(LispObject v)
inline LispObject &stream_byte_pos(LispObject v)
{   return basic_elt(v, 7);
}
inline AtomicLispObject &stream_char_pos(LispObject v)
inline LispObject &stream_char_pos(LispObject v)
{   return basic_elt(v, 8);
}
inline atomic<character_stream_reader *> &stream_read_fn(LispObject v)
{   return (atomic<character_stream_reader *>&)basic_elt(v, 9);
inline character_stream_reader *& stream_read_fn(LispObject v)
{   return (character_stream_reader *&)basic_elt(v, 9);
}
inline atomic<other_stream_op *> &stream_read_other(LispObject v)
{   return (atomic<other_stream_op *>&)basic_elt(v,10);
inline other_stream_op *& stream_read_other(LispObject v)
{   return (other_stream_op *&)basic_elt(v,10);
}
inline AtomicLispObject &stream_pushed_char(LispObject v)
inline LispObject &stream_pushed_char(LispObject v)
{   return basic_elt(v, 11);
}
inline AtomicLispObject &stream_spare(LispObject v)
inline LispObject &stream_spare(LispObject v)
{   return basic_elt(v, 12);
}

inline LispObject set_stream_file(LispObject v, std::FILE *x)
{   return (basic_elt(v, 3) = reinterpret_cast<LispObject>(x));
}
inline LispObject set_stream_write_fn(LispObject v,
                                      character_stream_writer *x)
inline LispObject set_stream_write_fn(LispObject v, character_stream_writer *x)
{   return (basic_elt(v, 4) = reinterpret_cast<LispObject>(x));
}
inline LispObject set_stream_write_other(LispObject v,
        other_stream_op *x)
inline LispObject set_stream_write_other(LispObject v, other_stream_op *x)
{   return (basic_elt(v, 5) = reinterpret_cast<LispObject>(x));
}
inline LispObject set_stream_read_fn(LispObject v,
                                     character_stream_reader *x)
inline LispObject set_stream_read_fn(LispObject v, character_stream_reader *x)
{   return (basic_elt(v, 9) = reinterpret_cast<LispObject>(x));
}
inline LispObject set_stream_read_other(LispObject v,
                                        other_stream_op *x)
inline LispObject set_stream_read_other(LispObject v, other_stream_op *x)
{   return (basic_elt(v, 10) = reinterpret_cast<LispObject>(x));
}


M csl/cslbase/tags.h => csl/cslbase/tags.h +74 -106
@@ 68,19 68,31 @@ typedef intptr_t LispObject;

typedef uintptr_t Header;

#if defined CONSERVATIVE || defined WITH_ATOMIC_DATA
typedef std::atomic<LispObject>     AtomicLispObject;
typedef std::atomic<Header>         AtomicHeader;
typedef std::atomic<std::uint32_t>  AtomicUint32;
typedef std::atomic<std::intptr_t>  AtomicIntPtr;
typedef std::atomic<std::uintptr_t> AtomicUintPtr;
#else
typedef LispObject     AtomicLispObject;
typedef Header         AtomicHeader;
typedef std::uint32_t  AtomicUint32;
typedef std::intptr_t  AtomicIntPtr;
typedef std::uintptr_t AtomicUintPtr;
#endif
// The following is a really rather dodgy idea. Suppose a have variables
// LispObject x, *y;
// Then I will be able to go things like
//    ... AT(X) ...
//    ... AT(*y) ...
//    AT(x) = ...
//    AT(*y) = ...
// and the AT() wrapper should lead to the access to the stored values being
// performed as an atomic operation with sequentially_consistent memory
// ordering imposed. Neither the compiler not hardware (such as a memory
// write pipeline or buffer) should then re-order access to other values
// past this one, and if one thread stores a value and then another reads
// the same item then the two threads should then be in step as regards not
// just that particular transaction but all others that have happened
// previously.
// The reinterpret_cast here is in violation of C++ strict aliasing rules
// and there is no guarantee that the representation in memory of T and
// std::atomic<T> match but it seems to me that it would be a very brave
// compiler that omitted a load or store involving the raw data (ie x or y)
// or relied on a cached value past an atomic access.

template <typename T>
std::atomic<T>& AT(T& x)
{   return reinterpret_cast<std::atomic<T>>(x);
}

// Perhaps the most important value here is nil!
extern LispObject nil;


@@ 361,53 373,9 @@ inline bool car_legal(LispObject p)
{   return is_cons(p);
}

// Either if CONBSERVATIVE or USE_ATOMIC_DATA is set I will make (eg)
// AtomicLispObject be a name for std::atomic<LispObject>, otherwise it is
// just a plain LispObject>

// Thus I may have many uses of atomic<T> here. The intent of these is to
// arrange that the heap is treated as made up of atomic data - certainly as
// far as all the LispObject and other sharable or mutable values in it are
// concerned.

// The C++ type atomic<T> has two aspects. The first is that even in
// an extreme case where the compiler/computer performs all memory references
// byte at a time both reads and writes will process whole values. This
// is strongly desirable in any multi-thread world, but apart from the
// special case of float128_t it will happen anyway on all reasonable
// computers.
// The second involves potential re-ordering of memory reads and writes
// either by software or by hardware. There are a range of options with
// "relaxed" essentially not applying any constraints. For lock-free multi-
// thread work the issues there really matter, but are "delicate". I am
// looking ahead to a multi-processing world, but trying to delay working
// out exactly what I need to do until later! It also through has implications
// about the way that one thread can or may not see memory changes made by
// another.
//
// What I do is I store LispObject values in the heap in the form
// atomic<LispObject> and provide pairs of accessor/mutator functions,
// eg CAR and SETCAR.

// I will protect the CAR and CDR field of every CONS cell this way,
// the header word of every symbol or vector-like object, and the
// value, env, pname, plist, fastgets and count fields with symbols.
// I do NOT protect the function-pointers within symbols.
// For vectors that contain pointers to other lisp objects I use
// atomic<T>, while for binary data (floating point numbers, character
// strings and so on) I do not.

// The reasoning here is that there will be times when multiple threads
// might all access the same list, vector or symbol and potentially update
// it. In particular I hope in due course to use several threads for
// garbage collection and that will involve some lock-free traversal
// of data. But binary data within Lisp objects will (generally) be read-
// only once it has been created, and so the worst issues of inter-thread
// synchronization will not arise.

typedef struct Cons_Cell_
{   AtomicLispObject car;
    AtomicLispObject cdr;
{   LispObject car;
    LispObject cdr;
} Cons_Cell;




@@ 420,12 388,12 @@ extern bool valid_address(void *pointer);
// arguments relating to that. The default relaxed behaviour should be best
// for performance if not for multi-thread consistency.

inline AtomicLispObject &car(LispObject p)
inline LispObject &car(LispObject p)
{   //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid car");
    return reinterpret_cast<Cons_Cell *>(p)->car;
}

inline AtomicLispObject &cdr(LispObject p)
inline LispObject &cdr(LispObject p)
{   //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid cdr");
    return reinterpret_cast<Cons_Cell *>(p)->cdr;
}


@@ 440,12 408,12 @@ inline void setcdr(LispObject p, LispObject q)
    reinterpret_cast<Cons_Cell *>(p)->cdr = q;
}

inline AtomicLispObject *caraddr(LispObject p)
inline LispObject *caraddr(LispObject p)
{   //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid caraddr");
    return &((reinterpret_cast<Cons_Cell *>(p))->car);
}

inline AtomicLispObject *cdraddr(LispObject p)
inline LispObject *cdraddr(LispObject p)
{   //if (!is_cons(p) || !valid_address((void *)p)) my_abort("invalid cdraddr");
    return &((reinterpret_cast<Cons_Cell *>(p))->cdr);
}


@@ 670,12 638,12 @@ static constexpr uintptr_t SPID_NOARG     = TAG_SPID+(0x0a<<(Tw+4)); // Missing 
static constexpr uintptr_t SPID_NOPROP    = TAG_SPID+(0x0b<<(Tw+4)); // fastget entry is empty
static constexpr uintptr_t SPID_LIBRARY   = TAG_SPID+(0x0c<<(Tw+4)); // + 0xnnn00000 offset

inline AtomicHeader &vechdr(LispObject v)
{   return *reinterpret_cast<AtomicHeader *>(v - TAG_VECTOR);
inline Header &vechdr(LispObject v)
{   return *reinterpret_cast<Header *>(v - TAG_VECTOR);
}

inline void setvechdr(LispObject v, Header h)
{   *reinterpret_cast<AtomicHeader *>(
{   *reinterpret_cast<Header *>(
        reinterpret_cast<char *>(v) - TAG_VECTOR) = h;
}



@@ 762,18 730,18 @@ static constexpr uintptr_t  SYM_UNPRINTED_GENSYM= 0x00800000; // not-yet-printed
#endif // COMMON

typedef struct Symbol_Head_
{   AtomicHeader header;       // Header as for other vector-like types
    AtomicLispObject value;    // Global or special value cell
{   Header header;       // Header as for other vector-like types
    LispObject value;    // Global or special value cell
//
    AtomicLispObject env;      // Extra stuff to help function cell
    AtomicLispObject plist;    // A list
    LispObject env;      // Extra stuff to help function cell
    LispObject plist;    // A list
//
    AtomicLispObject fastgets; // to speed up flagp and get
    AtomicLispObject package;  // Home package - a package object
    LispObject fastgets; // to speed up flagp and get
    LispObject package;  // Home package - a package object
//
    AtomicLispObject pname;    // A string (always)
    AtomicUint32 countLow;   // for statistics
    AtomicUint32 countHigh;  // for statistics
    LispObject pname;    // A string (always)
    uint32_t countLow;   // for statistics
    uint32_t countHigh;  // for statistics
//
    no_args *function0;      // Executable code always (no arguments)
    one_arg *function1;      // Executable code always (just 1 arg)


@@ 955,8 923,8 @@ inline bool vector_f128(Header h)
{   return ((0x80400000u >> ((h >> (Tw+2)) & 0x1f)) & 1) != 0;
}

inline AtomicLispObject& basic_elt(LispObject v, size_t n)
{   return *reinterpret_cast<AtomicLispObject *>
inline LispObject& basic_elt(LispObject v, size_t n)
{   return *reinterpret_cast<LispObject *>
           (reinterpret_cast<char *>(v) +
            (CELL-TAG_VECTOR) +
            (n*sizeof(LispObject)));


@@ 1033,21 1001,21 @@ static constexpr uintptr_t TYPE_DOUBLE_FLOAT   = 0x5f<<Tw;
static constexpr uintptr_t TYPE_NEW_BIGNUM     = 0x7d<<Tw;  // Temporary provision!
static constexpr uintptr_t TYPE_LONG_FLOAT     = 0x7f<<Tw;

inline AtomicHeader &numhdr(LispObject v)
{   return *reinterpret_cast<AtomicHeader *>(v - TAG_NUMBERS);
inline Header &numhdr(LispObject v)
{   return *reinterpret_cast<Header *>(v - TAG_NUMBERS);
}

inline AtomicHeader &flthdr(LispObject v)
{   return *reinterpret_cast<AtomicHeader *>(v - TAG_BOXFLOAT);
inline Header &flthdr(LispObject v)
{   return *reinterpret_cast<Header *>(v - TAG_BOXFLOAT);
}

inline void setnumhdr(LispObject v, Header h)
{   *reinterpret_cast<AtomicHeader *>(
{   *reinterpret_cast<Header *>(
         reinterpret_cast<char *>(v) - TAG_NUMBERS) = h;
}

inline void setflthdr(LispObject v, Header h)
{   *reinterpret_cast<AtomicHeader *>(
{   *reinterpret_cast<Header *>(
         reinterpret_cast<char *>(v) - TAG_BOXFLOAT) = h;
}



@@ 1403,7 1371,7 @@ inline void discard_vector(LispObject v)
// I should probably consider using a template to generate the code
// here.

inline AtomicLispObject& elt(LispObject v, size_t n)
inline LispObject& elt(LispObject v, size_t n)
{   if (is_basic_vector(v)) return basic_elt(v, n);
    return basic_elt(basic_elt(v, n/(VECTOR_CHUNK_BYTES/CELL)),
                     n%(VECTOR_CHUNK_BYTES/CELL));


@@ 1527,55 1495,55 @@ static constexpr LispObject CHAR_EOF = pack_char(0, 0x0010ffff);
static constexpr size_t MAX_FASTGET_SIZE = 63;
// I have up to 63 "fast" tags for PUT/GET/FLAG/FLAGP

inline AtomicHeader &qheader(LispObject p)
inline Header &qheader(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->header;
}

inline AtomicLispObject &qvalue(LispObject p)
inline LispObject &qvalue(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->value;
}

inline AtomicLispObject &qenv(LispObject p)
inline LispObject &qenv(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->env;
}

inline AtomicLispObject &qplist(LispObject p)
inline LispObject &qplist(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->plist;
}

inline AtomicLispObject &qfastgets(LispObject p)
inline LispObject &qfastgets(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->fastgets;
}

inline AtomicLispObject &qpackage(LispObject p)
inline LispObject &qpackage(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->package;
}

inline AtomicLispObject &qpname(LispObject p)
inline LispObject &qpname(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->pname;
}

inline AtomicLispObject *valueaddr(LispObject p)
inline LispObject *valueaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->value);
}

inline AtomicLispObject *envaddr(LispObject p)
inline LispObject *envaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->env);
}

inline AtomicLispObject *plistaddr(LispObject p)
inline LispObject *plistaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->plist);
}

inline AtomicLispObject *fastgetsaddr(LispObject p)
inline LispObject *fastgetsaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->fastgets);
}

inline AtomicLispObject *packageaddr(LispObject p)
inline LispObject *packageaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->package);
}

inline AtomicLispObject *pnameaddr(LispObject p)
inline LispObject *pnameaddr(LispObject p)
{   return &(reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->pname);
}



@@ 1682,11 1650,11 @@ inline bool a4a5a6(const char *name, LispObject a4up,
// field wraps. It leaves 42 bits for the genuine bytecount. That could
// overflow on a calculation that lasted an hour or so!

inline AtomicUint32& qcountLow(LispObject p)
inline uint32_t& qcountLow(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->countLow;
}

inline AtomicUint32& qcountHigh(LispObject p)
inline uint32_t& qcountHigh(LispObject p)
{   return reinterpret_cast<Symbol_Head *>(p-TAG_SYMBOL)->countHigh;
}



@@ 1789,9 1757,9 @@ inline uintptr_t pack_hdrlength(size_t n)
}

typedef struct Rational_Number_
{   AtomicHeader header;
    AtomicLispObject num;
    AtomicLispObject den;
{   Header header;
    LispObject num;
    LispObject den;
} Rational_Number;

inline LispObject numerator(LispObject r)


@@ 1815,9 1783,9 @@ inline void setdenominator(LispObject r, LispObject v)
}

typedef struct Complex_Number_
{   AtomicHeader header;
    AtomicLispObject real;
    AtomicLispObject imag;
{   Header header;
    LispObject real;
    LispObject imag;
} Complex_Number;

inline LispObject real_part(LispObject r)


@@ 1841,7 1809,7 @@ inline void setimag_part(LispObject r, LispObject v)
}

typedef struct Single_Float_
{   AtomicHeader header;
{   Header header;
    union float_or_int
    {   float f;
        float32_t f32;

M csl/cslbase/threadloc.h => csl/cslbase/threadloc.h +1 -1
@@ 51,7 51,7 @@
#define thread_local
#endif //AVOID_THREADLOCAL

#ifdef CONSERVATIVE
#if defined CONSERVATIVE && defined SUPPORT_MULTIPLE_THREADS

// The CONSERVATIVE build of CSL will be working towards support for
// multiple threads. So this code is activated there. Prior versions do

M csl/cslbase/version.h => csl/cslbase/version.h +1 -1
@@ 39,7 39,7 @@
// (scripts/commit.sh) that is used to update the subversion repository to
// update the revision number here.

#define REVISION 5979
#define REVISION 5990

#endif // header_version_h


M packages/redlog/rl/redlog.red => packages/redlog/rl/redlog.red +8 -29
@@ 281,29 281,8 @@ on1  'rlplsimpl;
switch rltnft;
on1 'rltnft;             % Return a "tree" instead of a "flat" tree normal form

switch rlgetrtypecar;
off1 'rlgetrtypecar;

procedure quotelog(x); 'logical;

procedure rl_getrtypecar(x);
   if !*rlgetrtypecar then rl_getrtypecar1 x else 'logical;

procedure rl_getrtypecar1(x);
   if eqcar(x, 'true) or eqcar(x, 'false) then
      'logical
   else
      (if w eq 'equation then 'logical else w) where w=getrtypecar x;

procedure rl_getrtypecadr(x);
   if !*rlgetrtypecar then rl_getrtypecadr1 x else 'logical;

procedure rl_getrtypecadr1(x);
   if cadr x eq 'true or cadr x eq 'false then
      'logical
   else
      (if w eq 'equation then 'logical else w) where w=getrtype cadr x;

put('logical, 'tag, '!*fof);
put('logical, 'evfn, 'rl_reval);
put('logical, 'subfn, 'rl_sub!*fof);


@@ 348,7 327,7 @@ rl_builtin {
   }
};

put('and, 'rtypefn, 'rl_getrtypecar);
put('and, 'rtypefn, 'quotelog);
put('and, 'rl_simpfn, 'rl_simpbop);
put('and, 'rl_prepfn, 'rl_prepbop);



@@ 365,7 344,7 @@ rl_builtin {
   }
};

put('or, 'rtypefn, 'rl_getrtypecar);
put('or, 'rtypefn, 'quotelog);
put('or, 'rl_simpfn, 'rl_simpbop);
put('or, 'rl_prepfn, 'rl_prepbop);



@@ 380,7 359,7 @@ rl_builtin {
   }
};

put('not, 'rtypefn, 'rl_getrtypecar);
put('not, 'rtypefn, 'quotelog);
put('not, 'rl_simpfn, 'rl_simpbop);
put('not, 'rl_prepfn, 'rl_prepbop);



@@ 400,7 379,7 @@ rl_builtin {
};

algebraic infix impl;
put('impl, 'rtypefn, 'rl_getrtypecar);
put('impl, 'rtypefn, 'quotelog);
put('impl, 'rl_simpfn, 'rl_simpbop);
put('impl, 'rl_prepfn, 'rl_prepbop);
put('impl, 'number!-of!-args, 2);


@@ 419,7 398,7 @@ rl_builtin {
};

algebraic infix repl;
put('repl, 'rtypefn, 'rl_getrtypecar);
put('repl, 'rtypefn, 'quotelog);
put('repl, 'rl_simpfn, 'rl_simpbop);
put('repl, 'rl_prepfn, 'rl_prepbop);
put('repl, 'number!-of!-args, 2);


@@ 438,7 417,7 @@ rl_builtin {
};

algebraic infix equiv;
put('equiv, 'rtypefn, 'rl_getrtypecar);
put('equiv, 'rtypefn, 'quotelog);
put('equiv, 'rl_simpfn, 'rl_simpbop);
put('equiv, 'rl_prepfn, 'rl_prepbop);
put('equiv, 'number!-of!-args, 2);


@@ 465,7 444,7 @@ rl_builtin {
   }
};

put('ex, 'rtypefn, 'rl_getrtypecadr);
put('ex, 'rtypefn, 'quotelog);
put('ex, 'rl_simpfn, 'rl_simpq);
put('ex, 'number!-of!-args, 2);
put('ex, 'rl_prepfn, 'rl_prepq);


@@ 485,7 464,7 @@ rl_builtin {
   }
};

put('all, 'rtypefn, 'rl_getrtypecadr);
put('all, 'rtypefn, 'quotelog);
put('all, 'rl_simpfn, 'rl_simpq);
put('all, 'number!-of!-args, 2);
put('all, 'rl_prepfn, 'rl_prepq);

M packages/support/revision.red => packages/support/revision.red +1 -1
@@ 31,6 31,6 @@

fluid '(revision!*);

revision!* := 5989;
revision!* := 5990;

end;

M scripts/test1.sh => scripts/test1.sh +11 -6
@@ 193,15 193,15 @@ p=${1:-alg}
if test "x$p" = "xregressions"
then
  r=${2:-aug-29-2011}
  printf "Regression test %s\n                     " "$r:"
  printf "Regression test %s\n                 " "$r:"
  p="$r"
  d="regressions"
else
  if test "x$2" = "x"
  then
    printf "Testing %-12s " "$p:"
    printf "Test %-11s " "$p:"
  else
    printf "Testing %-12s " "$p/$2:"
    printf "Test %-11s " "$p/$2:"
  fi
  w=`grep " test " $here/packages/package.map | grep "($p "`
  case $w in


@@ 374,7 374,10 @@ csltest() {
    case $name in
    installed* | csl=*)
      fullcommand="$command $CSLFLAGS"
# When I put "--csl=HOST-TRIPLE" 
      name="${name#csl=}"
      name="${name#*-*-}"
      showname="${showname#*-*-}"
      ;;
    *)
      if test "$name" = "cslboot1"


@@ 449,7 452,7 @@ XXX
    cat $name-times/$p.showtime >> $name-times/showtimes
  fi
  cat $p.howlong.tmp >> $name-times/$p.rlg.tmp
  printf $showname...
  printf $showname..
  sed -e "/^Tested on /,//d" <$rlgfile |
    sed -e "$SED1" >$name-times/$p.rlg.orig
  sed -e "1,/START OF REDUCE TEST RUN/d" -e "/END OF REDUCE TEST RUN/,//d" \


@@ 523,7 526,7 @@ XXX
    cat $name-times/$p.showtime >> $name-times/showtimes
  fi
  cat $p.howlong.tmp >> $name-times/$p.rlg.tmp
  printf $showname...
  printf $showname..
  sed -e "/^Tested on /,//d" <$rlgfile |
    sed -e "$SED1" >$name-times/$p.rlg.orig
  sed -e "1,/START OF REDUCE TEST RUN/d" -e "/END OF REDUCE TEST RUN/,//d" \


@@ 599,7 602,7 @@ XXX
    cat $name-times/$p.showtime >> $name-times/showtimes
  fi
  cat $p.howlong.tmp >> $outdir/$p.rlg.tmp
  printf "$showname..."
  printf "$showname.."
  sed -e "/^Tested on /,//d" <$rlgfile | \
    sed -e "$SED1" >$outdir/$p.rlg.orig
  sed -e "1,/START OF REDUCE TEST RUN/d" -e "/END OF REDUCE TEST RUN/,//d" \


@@ 700,6 703,7 @@ then
  for sys in $platforms
  do
    sys="${sys#csl=}"
    sys="${sys#*-*-}"
    if test "$sys" = "cslboot1"
    then
      sys="cslboot"


@@ 748,6 752,7 @@ then
  for sys in $platforms
  do
    sys="${sys#csl=}"
    sys="${sys#*-*-}"
    if test "$sys" = "cslboot1"
    then
      sys="cslboot"

M scripts/testall.sh => scripts/testall.sh +9 -2
@@ 82,7 82,8 @@ do
    then
      plist="$a"
      platforms="$sys"
      base="$sys"
      base=${sys#csl=}
      base="${base#*-*-}"
    else
      plist="$plist $a"
      platforms="$platforms $sys"


@@ 118,6 119,7 @@ then
  for sys in $platforms
  do
    sys=${sys#csl=}
    sys=${sys#*-*-}
    if test "$sys" = "cslboot1"
    then
      sys="cslboot"


@@ 150,6 152,7 @@ then
  for sys in $platforms
  do
    sys=${sys#csl=}
    sys=${sys#*-*-}
    if test "$sys" = "cslboot1"
    then
      sys="cslboot"


@@ 165,6 168,7 @@ then
  for sys in $platforms
  do
    sys=${sys#csl=}
    sys=${sys#*-*-}
    d=`cd $sys-times; echo *.rlg.diff`
    if test "$d" != "*.rlg.diff"
    then


@@ 175,6 179,7 @@ then
  for sys in $platforms
  do
    sys=${sys#csl=}
    sys=${sys#*-*-}
    if test "$sys" != "$base"
    then
      d=`cd $base-$sys-times-comparison; echo *.rlg.diff`


@@ 240,7 245,9 @@ do
    reporttime "installedCSL" "installed-csl-times"
    ;;
  csl=*)
    reporttime "${sys#csl=}" "${sys#csl=}-times"
    sys=${sys#csl=}
    sys=${sys#*-*-}
    reporttime "${sys}" "${sys}-times"
    ;;
  jlisp)
    reporttime "Jlisp" "jlisp-times"