davide@maverick.cad.mcc.com (David Eckelkamp) (11/13/90)
In 2 following postings you should find the rest of the patch to
integrate support for the Sun4, Sun3, Apollo and I386 into the 28sep90
version of Scheme->C. These tree postings will eventually show up on
gatekeeper.dec.com as MCC-28sep90.patches. (This will happen when
Joel Bartlett returns from vacation :-) The rest of this message is
the explanatory text at the beginning of the patch. The second message
is the modified files and the 3rd message contains the new files (in
patch format).
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
What is it?
===========
This file is an integrated set of patches for the 28sep90 version
of the Scheme->C system. These patches add support for the
Sun4/Sparcstation (SPARC), the Sun3 (SUN3), the Apollo DNx500
(APOLLO) and DN1000 (PRISM) series, and the the 386 (running ISC
Unix ?). Most of this is not new work, I simply integrated all the
patches that were posted for the 23feb90 version.
I have verified this patch on the following machine/OS combinations:
Sun4 - SunOS 4.0.3
Sun4 - SunOS 4.1
Sun3 - SunOS 4.0.3
Apollo DN3500 - Domain/OS SR10.2
DECSTATION 5100 - Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2 System #3
How to use it.
==============
This patch was generated against a fresh, unmodified version of the
28sep90 release of Scheme->C. I suggest you start with the original
tar file and untar it.
1. cd into the top directory of the distribution. You should see
something like this from ls -F:
CHANGES README doc/ scrt/ xlib/
MIPS VAX gnuemacs/ scsc/
RCS/ cdecl/ makefile test/
2. Run the patch file through the patch program, like this ("this"
assumes the patch file lives in the directory that is the top of
the distribution):
patch -p -b ".MCC" <MCC-28sep90.patches
When patch is done, check to be sure there were no rejections.
This can be done with the following command:
find . -name '*.rej' -print
If there were rejections, find out why and correct them. If it
was due to a problem in the patch, please let me know. (I tried
the patch on the above machines and it works for me :-)
3. Edit the top level makefile (./makefile) to fix up the
definition of SRCDIR at a minimum. You may also want to change
the various *DIR, *BIN, and *LIB macros that are appropriate for
your environment.
4. Run a "make for<ARCH>" command, where ARCH is one of APOLLO,
I386, MIPS, PRISM, SPARC, SUN3, TITAN, or VAX. This will create
the $(CPUDIR) directory, if it does not exist. It will then
create a tree of symbolic links to all the directories and
necessary files in the distribution.
[ If you can accept the values for CPUDIR that already exist in
the makefile, you can just say "make for<ARCH> SRCDIR=$PWD"
where $PWD has a valid pathname to the currect directory]
5. cd into $(SRCDIR) which you set in #3 above.
6. Do a "make port"
7. Verify the build as in step #4 in the README file.
More comments
=============
Like I said, very little of this work is original. I simply took
all the patches produced for the 23sep90 version and made them
work. This involved fixing rejections, adding some new parts to
the changes and removing some changes because the bug/problem they
addressed was already fixed in the 28sep90 version. Here is a list
of the authors of the original patches:
SPARC - rec@arris.com (Roger Critchlow)
I386 - rec@arris.com (Roger Critchlow)
SUN3 - Mikael Pettersson <mpe@IDA.LiU.SE>
APOLLO - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com
PRISM - Ray Lischner {uunet,decwrl}!mntgfx!lisch or lisch@mentor.com
I am not able to verify the I386 nor the PRISM version of the
system. I don't have access to those kinds of machines. The I386
patches seemed to mix conditionals between the 386 and SysV. It
would be nice if someone with a 386 and SysV could figure out what
things are SysV requirements. There are more SysV problems,
though. You should look at the README that originally came with
Critchlow's SPARC-I386 patches.
The APOLLO and PRSIM machines don't usually have an assembler. Ray
Lischner provided the assembler source and an assembled .o file. I
have provided the uuencoded .o file. You could put the following
section into the APOLLO makefile header to convert the uuencoded
file into the .o file:
apollo.o: apollo.o.uu
uudecode apollo.o.uu
There may be problems with the assembler, even if you have it. The
assembler we have here at MCC will not take the muls.l or the
mulu.l instructions.
Conclusion
==========
I hope you find these changes useful. If you have any problems
please let me know. I appreciate any comments that you might have,
good or bad. You can reach me via eckelkamp@mcc.com or
uunet!cs.utexas.edu!milano!cadillac!davide.
____________________________________________________________________________
David Eckelkamp Microelectronics and Computer Technology Corp. (MCC)
eckelkamp@mcc.com 3500 W. Balcones Center Dr.
(512) 343-0978 Austin,TX 78759davide@maverick.cad.mcc.com (David Eckelkamp) (11/13/90)
*** /tmp/,RCSt1a07923 Mon Nov 12 11:05:59 1990
--- makefile Mon Nov 12 11:03:15 1990
***************
*** 16,25 ****
--- 16,52 ----
VAXBIN = /wrl/vax/bin
VAXLIB = /wrl/vax/lib
+ APOLLODIR = $(SRCDIR)/apollo
+ APOLLOBIN = $(SRCDIR)/bin.apollo
+ APOLLOLIB = $(SRCDIR)/lib.apollo
+ PRISMDIR = $(SRCDIR)/prism
+ PRISMBIN = $(SRCDIR)/bin.prism
+ PRISMLIB = $(SRCDIR)/lib.prism
+
+ SPARCDIR = ${SRCDIR}/sparc
+ SPARCBIN = ${SRCDIR}/bin.sparc
+ SPARCLIB = ${SRCDIR}/lib.sparc
+
+ SUN3DIR = ${SRCDIR}/sun3
+ SUN3BIN = ${SRCDIR}/bin.sun3
+ SUN3LIB = ${SRCDIR}/lib.sun3
+
+ I386DIR = ${SRCDIR}/i386
+ I386BIN = ${SRCDIR}/bin.i386
+ I386LIB = ${SRCDIR}/lib.i386
+
+ # This is a list of the machines/architectures that are currently supported.
+ # These are also the names of the necessary makefile fragements.
+ MACHINES = APOLLO I386 MIPS PRISM SPARC SUN3 TITAN VAX
+
# Architecture specific directories and links to the source files are
# constructed by the following commands which follow:
+ no-target:
+ @echo 'Use "make for<target>", where <target> is one of:'
+ @echo ' $(MACHINES)'
+
forCPU:
-mkdir ${CPUDIR}
cp ${CPU} ${CPUDIR}
***************
*** 64,157 ****
-cd ${CPUDIR}/test; make srclinks
forMIPS:
! make "CPU = MIPS" "CPUDIR = ${MIPSDIR}" \
"BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU
forTITAN:
! make "CPU = TITAN" "CPUDIR = ${TITANDIR}" \
"BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU
forVAX:
! make "CPU = VAX" "CPUDIR = ${VAXDIR}" \
"BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU
# The Scheme->C system is initially compiled from the C sources by the
# following:
port:
! cd scrt; make port
! cd scsc; make port
# A "private" working copy of the current compiler, libary, and interpreter
# is installed in a directory by the following command:
install-private:
! cd scrt; make "destdir = ${destdir}" install-private
! cd scsc; make "destdir = ${destdir}" install-private
# Clean out working files.
clean:
rm -f *.BAK *.CKP SC-TO-C*
! cd doc; make clean
! cd scrt; make clean
! cd scsc; make clean
! cd test; make clean
# Clean up C source files generated from Scheme source.
clean-sc-to-c:
! cd scrt; make clean-sc-to-c
! cd scsc; make clean-sc-to-c
! cd test; make clean-sc-to-c
# Delete programs and libraries.
noprogs:
! cd scrt; make noprogs
! cd scsc; make noprogs
! cd test; make noprogs
# All binaries and documentation files are installed by the following command
# for access by all users.
install:
! cd doc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! cd scrt; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! cd scsc; make "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
# All files which must be constructed are made by the following command:
all:
! cd scrt; make all
! cd scsc; make all
# Distribute "source" files required to make the Scheme->C system.
srcdist:
! rdist -c MIPS README TITAN VAX makefile ${destdir}
! cd doc; make "destdir = ${destdir}/doc" srcdist
! -cd scbenchmark; make "destdir = ${destdir}/scbenchmark" srcdist
! cd scrt; make "destdir = ${destdir}/scrt" srcdist
! cd scsc; make "destdir = ${destdir}/scsc" srcdist
! -cd test; make "destdir = ${destdir}/test" srcdist
! -cd tools; make "destdir = ${destdir}/tools" srcdist
# Distribute "binary" files so that they may be installed on some other
# system.
bindist:
! rdist -c MIPS README TITAN VAX makefile ${destdir}
! cd doc; make "destdir = ${destdir}/doc" bindist
! cd scrt; make "destdir = ${destdir}/scrt" bindist
! cd scsc; make "destdir = ${destdir}/scsc" bindist
# Write the tar tape for distribution.
! TARFILES = CHANGES MIPS README VAX makefile \
doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \
gnuemacs/README gnuemacs/[a-z]* \
scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \
scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \
test/[a-z]*.sc test/test54c.c test/makefile-tail \
cdecl/README cdecl/[a-z]* \
--- 91,207 ----
-cd ${CPUDIR}/test; make srclinks
forMIPS:
! $(MAKE) "CPU = MIPS" "CPUDIR = ${MIPSDIR}" "SRCDIR = ${SRCDIR}" \
"BINDIR = ${MIPSBIN}" "LIBDIR = ${MIPSLIB}" forCPU
forTITAN:
! $(MAKE) "CPU = TITAN" "CPUDIR = ${TITANDIR}" "SRCDIR = ${SRCDIR}" \
"BINDIR = ${TITANBIN}" "LIBDIR = ${TITANLIB}" forCPU
forVAX:
! $(MAKE) "CPU = VAX" "CPUDIR = ${VAXDIR}" "SRCDIR = ${SRCDIR}" \
"BINDIR = ${VAXBIN}" "LIBDIR = ${VAXLIB}" forCPU
+ forAPOLLO:
+ $(MAKE) "CPU = APOLLO" "CPUDIR = ${APOLLODIR}" "SRCDIR = ${SRCDIR}" \
+ "BINDIR = ${APOLLOBIN}" "LIBDIR = ${APOLLOLIB}" forCPU
+ cd $(APOLLODIR)/scrt; ln -s $(SRCDIR)/mul-fix.perl mul-fix.perl
+
+ forPRISM:
+ $(MAKE) "CPU = PRISM" "CPUDIR = ${PRISMDIR}" "SRCDIR = ${SRCDIR}" \
+ "BINDIR = ${PRISMBIN}" "LIBDIR = ${PRISMLIB}" forCPU
+
+ forSPARC:
+ $(MAKE) "CPU = SPARC" "CPUDIR = ${SPARCDIR}" "SRCDIR = ${SRCDIR}" \
+ "BINDIR = ${SPARCBIN}" "LIBDIR = ${SPARCLIB}" forCPU
+
+
+ forSUN3:
+ $(MAKE) "CPU = SUN3" "CPUDIR = ${SUN3DIR}" "SRCDIR = ${SRCDIR}" \
+ "BINDIR=${SUN3BIN}" "LIBDIR=${SUN3LIB}" forCPU
+
+ forI386:
+ $(MAKE) "CPU = I386" "CPUDIR = ${I386DIR}" "SRCDIR = ${SRCDIR}" \
+ "BINDIR = ${I386BIN}" "LIBDIR = ${I386LIB}" forCPU
+
# The Scheme->C system is initially compiled from the C sources by the
# following:
port:
! cd scrt; $(MAKE) port
! cd scsc; $(MAKE) port
# A "private" working copy of the current compiler, libary, and interpreter
# is installed in a directory by the following command:
install-private:
! cd scrt; $(MAKE) "destdir = ${destdir}" install-private
! cd scsc; $(MAKE) "destdir = ${destdir}" install-private
# Clean out working files.
clean:
rm -f *.BAK *.CKP SC-TO-C*
! cd doc; $(MAKE) clean
! cd scrt; $(MAKE) clean
! cd scsc; $(MAKE) clean
! cd test; $(MAKE) clean
# Clean up C source files generated from Scheme source.
clean-sc-to-c:
! cd scrt; $(MAKE) clean-sc-to-c
! cd scsc; $(MAKE) clean-sc-to-c
! cd test; $(MAKE) clean-sc-to-c
# Delete programs and libraries.
noprogs:
! cd scrt; $(MAKE) noprogs
! cd scsc; $(MAKE) noprogs
! cd test; $(MAKE) noprogs
# All binaries and documentation files are installed by the following command
# for access by all users.
install:
! cd doc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! cd scrt; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
! cd scsc; $(MAKE) "BINDIR = ${BINDIR}" "LIBDIR = ${LIBDIR}" install
# All files which must be constructed are made by the following command:
all:
! cd scrt; $(MAKE) all
! cd scsc; $(MAKE) all
# Distribute "source" files required to make the Scheme->C system.
srcdist:
! rdist -c $(MACHINES) README makefile ${destdir}
! cd doc; $(MAKE) "destdir = ${destdir}/doc" srcdist
! -cd scbenchmark; $(MAKE) "destdir = ${destdir}/scbenchmark" srcdist
! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" srcdist
! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" srcdist
! -cd test; $(MAKE) "destdir = ${destdir}/test" srcdist
! -cd tools; $(MAKE) "destdir = ${destdir}/tools" srcdist
# Distribute "binary" files so that they may be installed on some other
# system.
bindist:
! rdist -c $(MACHINES) README makefile ${destdir}
! cd doc; $(MAKE) "destdir = ${destdir}/doc" bindist
! cd scrt; $(MAKE) "destdir = ${destdir}/scrt" bindist
! cd scsc; $(MAKE) "destdir = ${destdir}/scsc" bindist
# Write the tar tape for distribution.
! TARFILES = CHANGES README $(MACHINES) makefile \
doc/[a-z]*.mss doc/[a-z]*.psf doc/[a-z]*.l doc/makefile \
gnuemacs/README gnuemacs/[a-z]* \
scrt/[a-z]*.sc scrt/[a-z]*.[chs] scrt/makefile-tail \
+ scrt/[a-z]*.asm \
scsc/[a-z]*.sc scsc/[a-z]*.c scsc/[a-z]*.sch scsc/makefile-tail \
test/[a-z]*.sc test/test54c.c test/makefile-tail \
cdecl/README cdecl/[a-z]* \
*** /tmp/,RCSt1a27358 Fri Nov 9 17:25:53 1990
--- scrt/apply.h Fri Nov 9 14:05:39 1990
***************
*** 44,57 ****
by the compiler to call unknown functions.
*/
- #ifdef MIPS
- #define MAXARGS 25 /* Maximum number of required arguments permitted.
- Note that this does not preclude an optional
- argument list as an additional argument. This
- number is typically determined by the ability
- of one's C compiler. */
- #endif
-
#ifdef TITAN
#define MAXARGS 16 /* Maximum number of required arguments permitted.
Note that this does not preclude an optional
--- 44,49 ----
***************
*** 58,66 ****
argument list as an additional argument. This
number is typically determined by the ability
of one's C compiler. */
! #endif
!
! #ifdef VAX
#define MAXARGS 25 /* Maximum number of required arguments permitted.
Note that this does not preclude an optional
argument list as an additional argument. This
--- 50,56 ----
argument list as an additional argument. This
number is typically determined by the ability
of one's C compiler. */
! #else
#define MAXARGS 25 /* Maximum number of required arguments permitted.
Note that this does not preclude an optional
argument list as an additional argument. This
*** /tmp/,RCSt1a27363 Fri Nov 9 17:25:55 1990
--- scrt/callcc.c Fri Nov 9 14:05:43 1990
***************
*** 57,62 ****
--- 57,74 ----
#include "callcc.h"
#include "apply.h"
#include "signal.h"
+
+ #ifdef SPARC
+ extern sc_setjmp();
+ /* This is really tacky, but it appears to be necessary because of the */
+ /* compiler on the DECStation 5100. That beast does not seem to be able to */
+ /* grok the #pragma directive. The one I tried appeared to be */
+ /* Ultrix T3.1D-0 (Rev. 45) Worksystem X2.2. */
+ #include "sparc-pragma.h"
+ #define setjmp( x ) sc_setjmp( x )
+ #define longjmp( x, y ) sc_longjmp( x, y )
+ #endif
+
#ifdef MIPS
extern sc_setsp();
#endif
***************
*** 66,71 ****
--- 78,92 ----
#define setjmp( x ) sc_setjmp( x )
#endif
+ #ifdef APOLLO
+ extern sc_setregs(int a6, int a7);
+ #endif
+
+ #ifdef PRISM
+ #define longjmp(x, y) sc_longjmp(x, y)
+ #define setjmp(x) sc_setjmp(x)
+ #endif
+
TSCP sc_clink; /* Pointer to inner most continuation on stack. */
/* Static declarations for data structures internal to the module. These
***************
*** 97,102 ****
--- 118,127 ----
it will restore the stack. */
#ifdef MIPS
sc_setsp( (T_U(callcccp))->continuation.address );
+ #endif
+ #ifdef APOLLO
+ sc_setregs( (T_U(callcccp))->continuation.savedstate[3],
+ (T_U(callcccp))->continuation.savedstate[2]);
#endif
longjmp( (T_U(callcccp))->continuation.savedstate, 1 );
}
*** /tmp/,RCSt1a27372 Fri Nov 9 17:25:59 1990
--- scrt/cio.c Fri Nov 9 14:05:49 1990
***************
*** 46,51 ****
--- 46,64 ----
#include <sys/time.h>
#include "objects.h"
+ /* This really does not need to be dependant on ISC386IX, just the lack of */
+ /* a rename function. This is just a dirty hack. */
+ #ifdef ISC386IX
+ #include <stropts.h>
+ #include <poll.h>
+ int rename(old, new) char *old, *new;
+ {
+ if (link(old, new) == 0 && unlink(old) == 0)
+ return 0;
+ return -1;
+ }
+ #endif
+
int sc_libc_eof = EOF;
/* feof(stream) */
***************
*** 84,100 ****
--- 97,124 ----
input characters ready, and 0 when none are available.
*/
+ /* The changes here are probably generic Sys5 changes, but what the heck */
int sc_inputchars( stream )
FILE *stream;
{
int readfds, nfound;
+ #ifndef ISC386IX
struct timeval timeout;
+ #else
+ struct pollfd pollfd;
+ #endif
if (((stream)->_cnt) <= 0) {
+ #ifndef ISC386IX
readfds = 1<<(fileno( stream ));
timeout.tv_sec = 0;
timeout.tv_usec = 0;
nfound = select( fileno( stream )+1, &readfds, 0, 0, &timeout );
+ #else
+ pollfd.fd = fileno( stream );
+ pollfd.events = POLLIN;
+ nfound = poll(&pollfd, 1, 0);
+ #endif
if (nfound == 0) return( 0 );
}
return( 1 );
*** /tmp/,RCSt1a27381 Fri Nov 9 17:26:04 1990
--- scrt/heap.c Fri Nov 9 14:05:58 1990
***************
*** 59,64 ****
--- 59,70 ----
#ifdef VAX
extern sc_r2tor11();
#endif
+ #ifdef APOLLO
+ extern sc_regs();
+ #endif
+ #ifdef SUN3
+ extern sc_a2to5d2to7();
+ #endif
/* Forward declarations */
***************
*** 100,108 ****
--- 106,116 ----
int sc_gcinfo; /* controls logging */
+ #ifndef SYSV
static struct rusage gcru, /* resource consumption during collection */
startru,
stopru;
+ #endif
int *sc_stackbase; /* pointer to base of the stack */
***************
*** 111,116 ****
--- 119,125 ----
TSCP sc_after_2dcollect_v; /* Collection status callback */
+ #ifndef SYSV
/* The following function converts a rusage structure into an 18 word Scheme
vector composed of the same items.
*/
***************
*** 241,246 ****
--- 250,260 ----
return( rusagevector( &gcru ) );
}
+ #else
+ #define getrusage(x,y) /* no operation */
+ #define updategcru() /* no operation */
+ #endif /* SYSV-BSD dependency */
+
/* Errors detected during garbage collection are logged by the following
procedure. If any errors occur, the program will abort after logging
them. More than 30 errors will result in the program being aborted at
***************
*** 348,354 ****
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif TITAN
#ifdef VAX
/* The following code is used to read the stack pointer. The register
--- 362,368 ----
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif /* TITAN */
#ifdef VAX
/* The following code is used to read the stack pointer. The register
***************
*** 374,380 ****
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif VAX
#ifdef MIPS
/* The following code is used to read the stack pointer. The register
--- 388,394 ----
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif /* VAX */
#ifdef MIPS
/* The following code is used to read the stack pointer. The register
***************
*** 400,408 ****
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif MIPS
/* The size of an extended object in words is returned by the following
function.
*/
--- 414,532 ----
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
! #endif /* MIPS */
+ #ifdef APOLLO
+ /* The following code is used to read the stack pointer. The register
+ number is passed in to force an argument to be on the stack, which in
+ turn can be used to find the address of the top of stack.
+ */
+ int *sc_processor_register( reg )
+ int reg;
+ {
+ return( ® );
+ }
+
+ /* All processor registers that might contain pointers are traced by the
+ following procedure.
+ */
+
+ static trace_stack_and_registers()
+ {
+ int i, a1toa4_d0tod7[12], *pp;
+
+ sc_regs( a1toa4_d0tod7 );
+ pp = STACKPTR;
+ while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
+ }
+ #endif /* APOLLO */
+
+ #ifdef PRISM
+ /* All processor registers that might contain pointers are traced by the
+ following procedure.
+ */
+
+ static trace_stack_and_registers()
+ {
+ int i, regs[12], *pp;
+
+ sc_regs( regs );
+ pp = STACKPTR;
+ while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
+ }
+ #endif /* PRISM */
+
+ #ifdef SPARC
+ /* All processor registers which might contain pointers are traced by the
+ following procedure.
+ */
+
+ static trace_stack_and_registers()
+ {
+ int i, *pp;
+ jmp_buf tmp;
+
+ pp = STACKPTR;
+ while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
+ }
+ #endif SPARC
+
+ #ifdef SUN3
+ /* The following code is used to read the stack pointer. The register
+ number is passed in to force an argument to be on the stack, which in
+ turn can be used to find the address of the top of stack.
+ */
+
+ int *sc_processor_register( reg )
+ int reg;
+ {
+ return( ®+1 );
+ }
+
+ /* All processor registers which might contain pointers are traced by the
+ following procedure.
+ */
+
+ static trace_stack_and_registers()
+ {
+ int i, a2to5d2to7[10], *pp;
+
+ sc_a2to5d2to7( a2to5d2to7 );
+ pp = STACKPTR;
+ while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
+ }
+ #endif SUN3
+
+
+ #ifdef I386
+ /* The following code is used to read the stack pointer. The register
+ number is passed in to force an argument to be on the stack, which in
+ turn can be used to find the address of the top of stack.
+ */
+
+ int *sc_processor_register( reg )
+ int reg;
+ {
+ return( ® );
+ }
+
+ /* All processor registers which might contain pointers are traced by the
+ following procedure.
+ */
+
+ static trace_stack_and_registers()
+ {
+ int i, *pp;
+ jmp_buf tmp;
+
+ setjmp(tmp);
+ pp = STACKPTR;
+ while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
+ }
+ #endif I386
+
+
/* The size of an extended object in words is returned by the following
function.
*/
***************
*** 1421,1426 ****
--- 1545,1551 ----
getrusage( 0, &stopru );
updategcru();
if (sc_gcinfo) {
+ #ifndef SYSV
fprintf( stderr,
" %d%% locked %d%% retained %d user ms",
(sc_lockcnt*100)/sc_heappages,
***************
*** 1430,1435 ****
--- 1555,1566 ----
" %d system ms %d page faults\n",
stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000,
stopru.ru_majflt );
+ #else
+ fprintf( stderr,
+ " %d%% locked %d%% retained\n",
+ (sc_lockcnt*100)/sc_heappages,
+ (sc_generationpages*100)/sc_heappages);
+ #endif
}
if (sc_gcinfo == 2) {
/* Perform additional consistency checks */
***************
*** 1663,1670 ****
--- 1794,1805 ----
the Scheme object with that value.
*/
+ #ifdef PRISM
+ TSCP sc_makefloat32( float value )
+ #else
TSCP sc_makefloat32( value )
float value;
+ #endif
{
SCP pp;
***************
*** 1673,1679 ****
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
! pp->unsi.gned = FLOAT32TAG;
}
else
pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
--- 1808,1815 ----
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
! pp->float32.tag = FLOAT32TAG;
! pp->float32.rest = 0;
}
else
pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
***************
*** 1685,1694 ****
--- 1821,1840 ----
/* 64-bit floating point numbers are constructed by the following function. It
is called with a 64-bit floating point value and it returns a pointer to
the Scheme object with that value.
+
+ On the Apollo Prism, it is vital that we use a function prototype,
+ so the compiler knows that the function's argument is being passed
+ in a register. Without the prototype, the argument is read from
+ the stack. See prism.asm for examples where it is simpler to pass
+ the argument in a register. Also see objects.h for the declaration.
*/
+ #ifdef PRISM
+ TSCP sc_makefloat64( double value )
+ #else
TSCP sc_makefloat64( value )
double value;
+ #endif
{
SCP pp;
***************
*** 1698,1704 ****
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
! pp->unsi.gned = FLOAT64TAG;
}
else
pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );
--- 1844,1851 ----
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
! pp->float64.tag = FLOAT64TAG;
! pp->float64.rest = 0;
}
else
pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );
*** /tmp/,RCSt1a27386 Fri Nov 9 17:26:09 1990
--- scrt/heap.h Fri Nov 9 14:06:04 1990
***************
*** 42,51 ****
--- 42,70 ----
/* Import definitions */
#ifndef rusage
+
+ #ifdef apollo
+ #include <sys/time.h>
+ #else
+ #ifdef SPARC
+ #include <sys/time.h>
+ #else
+ #ifdef SUN3
+ #include <sys/time.h>
+ #else
+ #ifndef SYSV
#include <time.h>
+ #endif
+ #endif
+ #endif
+ #endif
+
+ #ifndef SYSV
#include <sys/resource.h>
#endif
+ #endif
+
/* This module implements the object storage storage system for SCHEME->C.
Unlike most Lisp systems, it is not intended that SCHEME->C provide a
***************
*** 318,323 ****
--- 337,363 ----
#ifdef VAX
#define STACKPTR sc_processor_register( 14 )
+ #endif
+
+ #ifdef APOLLO
+ #define STACKPTR sc_processor_register( 7 )
+ #endif
+
+ #ifdef PRISM
+ extern int* prism_stack_frame(void);
+ #define STACKPTR prism_stack_frame()
+ #endif
+
+ #ifdef I386
+ #define STACKPTR sc_processor_register( 4 )
+ #endif
+
+ #ifdef SPARC
+ #define STACKPTR sc_processor_register( 0 )
+ #endif
+
+ #ifdef SUN3
+ #define STACKPTR sc_processor_register( 15 )
#endif
/* Some objects require cleanup actions when they are freed. For example,
No differences encountered
*** /tmp/,RCSt1a27395 Fri Nov 9 17:26:13 1990
--- scrt/makefile-tail Fri Nov 9 14:06:07 1990
***************
*** 34,40 ****
scqquote.sc screp.sc \
scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc
! Smisc = GGC.c GGC.h GGCprivate.h mips.s predef.sc repdef.sc sci.sc sci.c vax.s
${Sruntimec} sci.c: ${predef.sc} ${objects.h}
--- 34,41 ----
scqquote.sc screp.sc \
scrt1.sc scrt2.sc scrt3.sc scrt4.sc scrt5.sc scrt6.sc scrt7.sc
! Smisc = GGC.c GGC.h GGCprivate.h apollo.asm prism.asm mips.s predef.sc \
! repdef.sc sci.sc sci.c vax.s sparc.s i386.s sun3.s sparc-pragma.h
${Sruntimec} sci.c: ${predef.sc} ${objects.h}
***************
*** 49,54 ****
--- 50,60 ----
.c.u:
${CC} -j -D${cpu} -I. $*.c
+ # Apollo assembler
+ .asm.o:
+ $(ASM) $* $(AFLAGS)
+ -mv $*.bin $*.o
+
.s.o:
${CC} -c $*.s
***************
*** 69,75 ****
-lm
GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o
! make "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o
${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \
-lXaw -lXt -lX11 -lm
--- 75,81 ----
-lm
GGCi: ${Sruntimec} ${Sruntime} ${Aruntime} GGC.o sci.c sci.o
! $(MAKE) "CFLAGS = -DGGC ${CFLAGS}" GGCheap.o GGCscinit.o
${CC} -o GGCi ${CFLAGS} ${Sruntime} ${GGCCruntime} ${Aruntime} sci.o \
-lXaw -lXt -lX11 -lm
***************
*** 78,84 ****
mv Xlibsc.a libsc.a
port:
! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
Xlibsc.a Xsci Xmv ${Plib}
libsc_p.a: libsc.a
--- 84,90 ----
mv Xlibsc.a libsc.a
port:
! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
Xlibsc.a Xsci Xmv ${Plib}
libsc_p.a: libsc.a
***************
*** 85,91 ****
mkdir saveobj
mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj
rm -f libsc_p.a
! make "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \
${Aruntime}
ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime}
ranlib libsc_p.a
--- 91,97 ----
mkdir saveobj
mv ${Sruntime} ${Cruntime} ${Aruntime} saveobj
rm -f libsc_p.a
! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS} -pg" ${Sruntime} ${Cruntime} \
${Aruntime}
ar q libsc_p.a ${Cruntime} ${Sruntime} ${Aruntime}
ranlib libsc_p.a
***************
*** 127,133 ****
rm -f sci libsc.a libsc_p.a
srcdist:
! rdist -c README *.c *.h *.s *.sc makefile-tail ${destdir}
bindist:
rdist -c README makefile makefile-tail predef.sc objects.h \
--- 133,139 ----
rm -f sci libsc.a libsc_p.a
srcdist:
! rdist -c README *.c *.h *.s *.sc *.asm makefile-tail ${destdir}
bindist:
rdist -c README makefile makefile-tail predef.sc objects.h \
***************
*** 134,140 ****
libsc.a ${Plib} sci ${destdir}
all:
! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \
Xlibsc.a Xsci Xmv ${Plib}
srclinks:
--- 140,146 ----
libsc.a ${Plib} sci ${destdir}
all:
! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = ${sccomp}" \
Xlibsc.a Xsci Xmv ${Plib}
srclinks:
*** /tmp/,RCSt1a27404 Fri Nov 9 17:26:15 1990
--- scrt/objects.c Thu Nov 1 08:05:03 1990
***************
*** 482,488 ****
break;
case EXTENDEDTAG:
if (TX_U( p )->extendedobj.tag == FLOATTAG)
! return( (int)( TX_U( p )->FLOATUTYPE.value ) );
break;
}
sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
--- 482,488 ----
break;
case EXTENDEDTAG:
if (TX_U( p )->extendedobj.tag == FLOATTAG)
! return ROUND( FLOAT_VALUE( p ) );
break;
}
sc_error( "TSCP_INT", "Argument cannot be converted to C int", 0 );
***************
*** 506,514 ****
if (TX_U( p )->extendedobj.tag == FLOATTAG) {
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
! return( (unsigned)( v ) );
else
! return( (unsigned)( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
}
break;
--- 506,514 ----
if (TX_U( p )->extendedobj.tag == FLOATTAG) {
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
! return( (unsigned)ROUND( v ) );
else
! return( (unsigned)ROUND( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
}
break;
***************
*** 543,551 ****
case FLOATTAG:
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
! return( (unsigned)( v ) );
else
! return( (unsigned)( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
break;
}
--- 543,551 ----
case FLOATTAG:
v = TX_U( p )->FLOATUTYPE.value;
if (v <= (double)(0x7fffffff))
! return( (unsigned int)( v ) );
else
! return( (unsigned int)( v-((double)(0x40000000))*2.0 ) |
0x80000000 );
break;
}
*** /tmp/,RCSt1a27409 Fri Nov 9 17:26:19 1990
--- scrt/objects.h Fri Nov 9 14:06:14 1990
***************
*** 43,52 ****
*/
/* Default the value of CPUTYPE if not currently defined. */
-
#ifndef MIPS
#ifndef TITAN
#ifndef VAX
#ifdef mips
#define MIPS 1
#endif
--- 43,57 ----
*/
/* Default the value of CPUTYPE if not currently defined. */
#ifndef MIPS
#ifndef TITAN
#ifndef VAX
+ #ifndef SPARC
+ #ifndef SUN3
+ #ifndef I386
+ #ifndef APOLLO
+ #ifndef PRISM
+
#ifdef mips
#define MIPS 1
#endif
***************
*** 56,65 ****
--- 61,95 ----
#ifdef vax
#define VAX 1
#endif
+ #ifdef sun
+ # ifdef sparc
+ # define SPARC 1
+ # else
+ # ifdef mc68000
+ # define SUN3 1
+ # endif
+ # endif
#endif
+ #ifdef i386
+ #define I386 1
#endif
+ #ifdef apollo
+ # ifdef _ISP_A88K
+ # define PRISM 1
+ # else
+ # define APOLLO 1
+ # endif
#endif
+ #endif /* PRISM */
+ #endif /* APOLLO */
+ #endif /* I386 */
+ #endif /* SUN3 */
+ #endif /* SPARC */
+ #endif /* VAX */
+ #endif /* TITAN */
+ #endif /* MIPS */
+
/* The Scheme->C installer may elect to have arithmetic overflow handled
gracefully on either the MIPS or the VAX implementations. The default
is to handle it.
***************
*** 80,85 ****
--- 110,116 ----
#ifdef TITAN
#include <setjmp.h>
#define CPUTYPE TITAN
+ #undef MATHTRAPS
#endif
#ifdef VAX
***************
*** 96,101 ****
--- 127,174 ----
#define CPUTYPE VAX
#endif
+ #ifdef APOLLO
+ #include <setjmp.h>
+ #define CPUTYPE APOLLO
+ #define BIG_ENDIAN
+ #endif
+
+ #ifdef PRISM
+ /* Use our own setjmp/longjmp so we can make sure all the registers
+ are saved that need to be saved, namely, .10 through .23,
+ plus the signal mask, return PC, and PSWs.
+
+ The layout of these registers in the array is described in prism.asm.
+ */
+ typedef int jmp_buf[18];
+ #define CPUTYPE PRISM
+ #define BIG_ENDIAN
+ #endif
+
+ #ifdef SPARC
+ typedef int jmp_buf[2+7+8+8+1];
+ #define DOUBLE_ALIGN 1
+ #define CPUTYPE SPARC
+ #define BIG_ENDIAN
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+
+ #ifdef SUN3
+ #include <setjmp.h>
+ #define CPUTYPE SUN3
+ #define BIG_ENDIAN
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+
+ #ifdef I386
+ #include <setjmp.h>
+ #define CPUTYPE I386
+ #undef MATHTRAPS
+ #define MATHTRAPS 0
+ #endif
+
/* The data encoding scheme is similar to that used by Vax NIL and T, where
all objects are represented by 32-bit pointers, with a "low tag" encoded
in the two least significant bits encoding the type. All objects are
***************
*** 123,128 ****
--- 196,219 ----
struct STACKTRACE;
+ /*
+ Ugly, but machine independent way to declare and use bit fields:
+ Bit fields are declared using F?(...), where the least significant
+ fields are listed first (in honor of the original implementations).
+ Similarly, static objects are created with the U?(...) macros.
+ */
+ #ifdef BIG_ENDIAN
+ #define F2(a,b) b;a
+ #define F3(a,b,c) c;b;a
+ #define U2(a,b) (b),(a)
+ #define U3(a,b,c) (c),(b),(a)
+ #else
+ #define F2(a,b) a;b
+ #define F3(a,b,c) a;b;c
+ #define U2(a,b) (a),(b)
+ #define U3(a,b,c) (a),(b),(c)
+ #endif
+
typedef char *TSCP;
typedef union SCOBJ { /* SCHEME to C OBJECT */
***************
*** 130,141 ****
unsigned gned;
} unsi;
struct { /* EXTENDEDOBJ */
! unsigned tag:8;
! unsigned rest:24;
} extendedobj;
struct { /* SYMBOL */
! unsigned tag:8;
! unsigned rest:24;
TSCP name;
TSCP *ptrtovalue;
TSCP value;
--- 221,232 ----
unsigned gned;
} unsi;
struct { /* EXTENDEDOBJ */
! F2(unsigned tag:8,
! unsigned rest:24);
} extendedobj;
struct { /* SYMBOL */
! F2(unsigned tag:8,
! unsigned rest:24);
TSCP name;
TSCP *ptrtovalue;
TSCP value;
***************
*** 142,172 ****
TSCP propertylist;
} symbol;
struct { /* STRING */
! unsigned tag:8;
! unsigned length:24;
char char0;
} string;
struct { /* VECTOR */
! unsigned tag:8;
! unsigned length:24;
TSCP element0;
} vector;
struct { /* PROCEDURE */
! unsigned tag:8;
! unsigned required:8;
! unsigned optional:16;
TSCP (*code)();
TSCP closure;
} procedure;
struct { /* CLOSURE */
! unsigned tag:8;
! unsigned length:24;
TSCP closure;
TSCP var0;
} closure;
struct { /* CONTINUATION */
! unsigned tag:8;
! unsigned length:24;
TSCP continuation;
jmp_buf savedstate;
int *address;
--- 233,263 ----
TSCP propertylist;
} symbol;
struct { /* STRING */
! F2(unsigned tag:8,
! unsigned length:24);
char char0;
} string;
struct { /* VECTOR */
! F2(unsigned tag:8,
! unsigned length:24);
TSCP element0;
} vector;
struct { /* PROCEDURE */
! F3(unsigned tag:8,
! unsigned required:8,
! unsigned optional:16);
TSCP (*code)();
TSCP closure;
} procedure;
struct { /* CLOSURE */
! F2(unsigned tag:8,
! unsigned length:24);
TSCP closure;
TSCP var0;
} closure;
struct { /* CONTINUATION */
! F2(unsigned tag:8,
! unsigned length:24);
TSCP continuation;
jmp_buf savedstate;
int *address;
***************
*** 174,196 ****
int word0;
} continuation;
struct { /* FLOAT32 */
! unsigned tag:8;
! unsigned rest:24;
float value;
} float32;
struct { /* FLOAT64 */
! unsigned tag:8;
! unsigned rest:24;
double value;
} float64;
struct { /* FORWARD */
! unsigned tag:8;
! unsigned length:24;
TSCP forward;
} forward;
struct { /* WORDALIGN */
! unsigned tag:8;
! unsigned length:24;
} wordalign;
struct { /* PAIR */
TSCP car;
--- 265,287 ----
int word0;
} continuation;
struct { /* FLOAT32 */
! F2(unsigned tag:8,
! unsigned rest:24);
float value;
} float32;
struct { /* FLOAT64 */
! F2(unsigned tag:8,
! unsigned rest:24);
double value;
} float64;
struct { /* FORWARD */
! F2(unsigned tag:8,
! unsigned length:24);
TSCP forward;
} forward;
struct { /* WORDALIGN */
! F2(unsigned tag:8,
! unsigned length:24);
} wordalign;
struct { /* PAIR */
TSCP car;
***************
*** 220,225 ****
--- 311,332 ----
#define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
#define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
#endif
+ #ifdef apollo
+ #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef SPARC
+ #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef SUN3
+ #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
+ #ifdef I386
+ #define TX_U( tscp ) ((SCP)((char*)tscp-EXTENDEDTAG))
+ #define TP_U( tscp ) ((SCP)((char*)tscp-PAIRTAG))
+ #endif
/* Fixed point numbers are encoded in the address portion of the pointer. The
value is obtained by arithmetically shifting the pointer value two bits to
***************
*** 626,633 ****
--- 733,768 ----
When the procedure is exited, sc_stacktrace is restored. In order to assure
that sc_stacktrace always points to a valid entry, the list is maintained
by subroutines (compilers want to optimize it out!).
+
+ In dobacktrace(), the stack is traced by calling C-UNSIGNED-REF
+ to get the prevstacktrace pointer. The problem with this is that
+ C-UNSIGNED-REF (aka scrt4_c_2dunsigned_2dref) uses MUNSIGNED, which
+ uses T_U, which masks out the least significant two bits of the pointer.
+ The trick is to get an implementation independent method of aligning
+ the stacktrace structure. Most compilers at least align the structure
+ with an even address, but only some will align it on a four-byte boundary.
+
+ The macro ALIGN4(t,x) declares "x" to be a pointer to "t", aligned on
+ a 4-byte boundary. If nothing special needs to be done, then the default
+ definition can be used.
*/
+ #ifdef APOLLO
+ /* On an Apollo, things are usually aligned properly on the stack,
+ but after an interrupt, things can get screwy, and even doubles
+ can end up non-longword aligned. To be safe, we need to align
+ everything on a longword boundary ourselves.
+ */
+ #define IDENT(a) a
+ #define CAT(a,b) IDENT(a)b
+ #define ALIGN4(t,x) char CAT(x,buf)[sizeof(t) + sizeof(long)];\
+ t& x = * (t*) ((unsigned)CAT(x,buf) & ~(sizeof(long)-1))
+ #endif
+
+ /* the rest of the world does not need to worry about such matters */
+ #ifndef ALIGN4
+ #define ALIGN4(t,x) t x
+ #endif
struct STACKTRACE { /* Stack trace back record */
struct STACKTRACE* prevstacktrace;
TSCP procname;
***************
*** 636,642 ****
extern struct STACKTRACE *sc_stacktrace;
! #define PUSHSTACKTRACE( procedure ) struct STACKTRACE st; \
sc_pushtrace( &st, (procedure) )
#define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) )
--- 771,777 ----
extern struct STACKTRACE *sc_stacktrace;
! #define PUSHSTACKTRACE( procedure ) ALIGN4(struct STACKTRACE, st); \
sc_pushtrace( &st, (procedure) )
#define POPSTACKTRACE( exp ) return( sc_poptrace( &st, (exp) ) )
***************
*** 735,740 ****
--- 870,887 ----
#ifdef VAX
#define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
#endif
+ #ifdef apollo
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef SPARC
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef I386
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
+ #ifdef SUN3
+ #define VECTOR_ELEMENT( tscp, n ) (*((PATSCP)(((char*)( tscp ))+3+((int)n))))
+ #endif
#define PROCEDURE_REQUIRED( tscp ) (TX_U( tscp )->procedure.required)
#define PROCEDURE_OPTIONAL( tscp ) (TX_U( tscp )->procedure.optional)
***************
*** 753,768 ****
/* C declarations */
#define DEFSTRING( name, chars, len ) \
! static struct { unsigned tag:8; \
! unsigned length:24; \
char char0[len+(4-(len % 4))]; } \
! name = { STRINGTAG, len, chars }
#define DEFFLOAT( name, value ) \
! static struct { unsigned tag:8; \
! unsigned length: 24; \
FLOATTYPE f; } \
! name = { FLOATTAG, 0, value }
#define DEFTSCP( name ) TSCP name
--- 900,915 ----
/* C declarations */
#define DEFSTRING( name, chars, len ) \
! static struct { F2(unsigned tag:8, \
! unsigned length:24); \
char char0[len+(4-(len % 4))]; } \
! name = { U2(STRINGTAG, len), chars }
#define DEFFLOAT( name, value ) \
! static struct { F2(unsigned tag:8, \
! unsigned length: 24); \
FLOATTYPE f; } \
! name = { U2(FLOATTAG, 0), value }
#define DEFTSCP( name ) TSCP name
***************
*** 857,870 ****
/* C operators that detect integer overflow in some implementations */
! #if (MATHTRAPS == 0 || CPUTYPE == TITAN)
#define IPLUS( a, b ) (a + b)
#define IDIFFERENCE( a, b ) (a - b)
#define INEGATE( a ) (- a)
#define ITIMES( a, b ) (a * b)
- #endif
! #if (MATHTRAPS && (CPUTYPE == MIPS || CPUTYPE == VAX))
#define IPLUS( a, b ) sc_iplus( a, b )
#define IDIFFERENCE( a, b ) sc_idifference( a, b )
#define ITIMES( a, b ) sc_itimes( a, b )
--- 1004,1017 ----
/* C operators that detect integer overflow in some implementations */
! #if (MATHTRAPS == 0 || CPUTYPE == TITAN)
#define IPLUS( a, b ) (a + b)
#define IDIFFERENCE( a, b ) (a - b)
#define INEGATE( a ) (- a)
#define ITIMES( a, b ) (a * b)
! #else
!
#define IPLUS( a, b ) sc_iplus( a, b )
#define IDIFFERENCE( a, b ) sc_idifference( a, b )
#define ITIMES( a, b ) sc_itimes( a, b )
***************
*** 895,910 ****
significant 8 bits of the extended object header.
*/
! #define UNKNOWNCALL( proc, argc ) (sc_unknownargc = argc, \
! sc_unknownproc[ 1 ] = proc, \
! sc_unknownproc[ \
! (UNSI_GNED( \
! sc_unknownproc[ TSCPTAG( proc ) ] ) \
! == (argc*256+PROCEDURETAG)) ])
/* Inline type conversions */
! #define FLT_FIX( flt ) C_FIXED( (int)(FLOAT_VALUE( flt )) )
#define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) )
#define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix )))
#define FLTV_FLT( flt ) MAKEFLOAT( flt )
--- 1042,1073 ----
significant 8 bits of the extended object header.
*/
! #define UNKNOWNCALL( proc, argc ) \
! (sc_unknownargc = argc, sc_unknownproc[ 1 ] = proc, \
! sc_unknownproc[(PROCEDURE_REQUIRED(sc_unknownproc[ TSCPTAG(proc) ]) == argc\
! && ! PROCEDURE_OPTIONAL(sc_unknownproc[ TSCPTAG( proc )]))])
! /* UNSI_GNED(sc_unknownproc[ TSCPTAG( proc ) ] ) \
! == (argc*256+PROCEDURETAG)) ])
! */
/* Inline type conversions */
! /* round a floating point number to the nearest integer */
! #ifdef apollo
! #include <math.h>
! /* Apollo SR10.2, with cc 6.7: rint() returns a bogus value (e.g., 0.9
! is "rounded" to 0.899902).
! If Apollo does not fix rint() soon, then we should write our own.
! */
! #define rint(x) floor((x) + 0.5)
! #define ROUND(x) ((int) rint(x))
! #endif
!
! #ifndef ROUND
! #define ROUND(x) ((int) (x))
! #endif
!
! #define FLT_FIX( flt ) C_FIXED( ROUND(FLOAT_VALUE( flt )) )
#define FIX_FLT( fix ) MAKEFLOAT( (FLOATTYPE)(FIXED_C( fix )) )
#define FIX_FLTV( fix ) ((FLOATTYPE)(FIXED_C( fix )))
#define FLTV_FLT( flt ) MAKEFLOAT( flt )
***************
*** 953,960 ****
--- 1116,1132 ----
definitions needed by a SCHEME->C program.
*/
+ #ifdef PRISM
+ /* As explained in heap.c, it is important to declare the function prototype,
+ so the compiler passes the floating point argument in a register, rather
+ than on the stack.
+ */
+ extern TSCP sc_makefloat32(float);
+ extern TSCP sc_makefloat64(double);
+ #else
extern TSCP sc_makefloat32();
extern TSCP sc_makefloat64();
+ #endif
extern TSCP sc_cons();
extern int sc_unknownargc;
extern TSCP sc_unknownproc[ 4 ];
*** /tmp/,RCSt1a27478 Fri Nov 9 17:26:44 1990
--- scrt/scinit.c Fri Nov 9 14:06:20 1990
***************
*** 70,78 ****
#include <vax/vmparam.h>
#define STACKBASE (int*)USRSTACK
#endif
- #include <sys/file.h>
#include <sys/types.h>
#include <sys/uio.h>
#include <strings.h>
#include <varargs.h>
--- 70,106 ----
#include <vax/vmparam.h>
#define STACKBASE (int*)USRSTACK
#endif
+ #ifdef apollo
+ #define ETEXT ((int)&etext) /* First address after text */
+ #include <sys/param.h>
+ /* the stack back moves depending on shared libraries */
+ #include <apollo/base.h>
+ #include <apollo/error.h>
+ #include <apollo/proc2.h>
+ static proc2_$info_t sc_apollo_proc2;
+ #define STACKBASE ((int*) sc_apollo_proc2.stack_base)
+ #endif
+ #ifdef SPARC
+ #define ETEXT ((int)&etext) /* First address after text */
+ #include <sun4/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #endif
+ #ifdef SUN3
+ #define ETEXT ((int)&etext) /* First address after text */
+ #include <sun3/param.h>
+ #include <sun3/vmparam.h>
+ #define STACKBASE (int*)USRSTACK
+ #endif
+ #ifdef ISC386IX
+ #define ETEXT ((int)&etext) /* First address after text */
+ #include <sys/types.h>
+ #include <sys/fcntl.h> /* probably should be elsewhere */
+ #include <sys/immu.h>
+ #define STACKBASE (int*)UVSTACK
+ #endif
#include <sys/types.h>
+ #include <sys/file.h>
#include <sys/uio.h>
#include <strings.h>
#include <varargs.h>
***************
*** 96,103 ****
/* Global data structure for this module. */
! static int emptyvector = VECTORTAG,
! emptystring[2] = {STRINGTAG, 0};
FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */
*sc_stdout,
--- 124,135 ----
/* Global data structure for this module. */
! /* this struct must look like an SCOBJ */
! static struct
! {
! F2(unsigned tag:8,
! unsigned length:24);
! } emptyvector, emptystring[2];
FILE *sc_stdin, /* Standard I/O Subroutine FILE pointers */
*sc_stdout,
***************
*** 183,188 ****
--- 215,221 ----
static init_procs()
{
+ #ifndef SYSV
INITIALIZEVAR( U_TX( ADR( t1030 ) ),
ADR( sc_my_2drusage_v ),
MAKEPROCEDURE( 0,
***************
*** 192,197 ****
--- 225,231 ----
MAKEPROCEDURE( 0,
0,
sc_collect_2drusage, EMPTYLIST ) );
+ #endif
INITIALIZEVAR( U_TX( ADR( t1034 ) ),
ADR( sc_collect_v ),
MAKEPROCEDURE( 0,
***************
*** 288,293 ****
--- 322,340 ----
char *freebase;
TSCP unknown;
+ #ifdef apollo
+ /* on an apollo, we get the stack top at run time */
+ uid_$t me;
+ status_$t status;
+ proc2_$who_am_i(&me);
+ proc2_$get_info(me, &sc_apollo_proc2, sizeof(sc_apollo_proc2), &status);
+ if (status.all != status_$ok && status.all != proc2_$is_current)
+ {
+ error_$print(status);
+ exit(2);
+ }
+ #endif
+
if (sc_gcinfo)
fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCLIMIT = %d\n",
sc_gcinfo, scheap, sclimit );
***************
*** 319,324 ****
--- 366,373 ----
sc_mutex = 0;
sc_pendingsignals = 0;
sc_emptylist = EMPTYLIST;
+ emptyvector.tag = VECTORTAG;
+ emptystring[0].tag = STRINGTAG;
sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
sc_emptystring = U_T( emptystring, EXTENDEDTAG );
sc_falsevalue = FALSEVALUE;
***************
*** 557,562 ****
--- 606,617 ----
if (scheap < save.heappages/(ONEMB/PAGEBYTES))
scheap = save.heappages/(ONEMB/PAGEBYTES);
if (sclimit < save.limit) sclimit = save.limit;
+ #ifdef sun
+ /* in SunOS, stderr is line buffered, which causes some unwanted */
+ /* malloc.. */
+ if (sc_gcinfo)
+ setbuf(stderr, (char*)0);
+ #endif
if (sc_gcinfo)
fprintf( stderr, "***** SCGCINFO = %d SCHEAP = %d SCLIMIT = %d\n",
sc_gcinfo, scheap, sclimit );
***************
*** 602,607 ****
--- 657,664 ----
sc_mutex = 0;
sc_pendingsignals = 0;
sc_emptylist = EMPTYLIST;
+ emptyvector.tag = VECTORTAG;
+ emptystring[0].tag = STRINGTAG;
sc_emptyvector = U_T( &emptyvector, EXTENDEDTAG );
sc_emptystring = U_T( emptystring, EXTENDEDTAG );
sc_falsevalue = FALSEVALUE;
***************
*** 702,707 ****
--- 759,765 ----
scrt6_error( sc_string_2d_3esymbol( sc_cstringtostring( symbol ) ),
sc_cstringtostring( format ),
scrt1_reverse( argl ) );
+ va_end( argp );
}
/* The following function returns informations about the implementation. The
***************
*** 730,735 ****
--- 788,806 ----
#ifdef VAX
sc_cstringtostring( "VAX" ),
#endif
+ #ifdef apollo
+ sc_cstringtostring( "Apollo" ),
+ #endif
+ #ifdef SPARC
+ sc_cstringtostring( "Sun4/SPARC" ),
+ #endif
+ #ifdef SUN3
+ sc_cstringtostring( "Sun3" ),
+ #endif
+ #ifdef I386
+ sc_cstringtostring( "AT/386" ),
+ #endif
+
sc_cons(
#ifdef MIPS
sc_cstringtostring( "R2000" ),
***************
*** 740,747 ****
--- 811,853 ----
#ifdef VAX
sc_cstringtostring( "VAX" ),
#endif
+ #ifdef APOLLO
+ sc_cstringtostring( "68K" ),
+ #endif
+ #ifdef PRISM
+ sc_cstringtostring( "PRISM" ),
+ #endif
+ #ifdef SPARC
+ sc_cstringtostring( "SPARC" ),
+ #endif
+ #ifdef SUN3
+ sc_cstringtostring( "68K" ),
+ #endif
+ #ifdef I386
+ sc_cstringtostring( "Intel 386" ),
+ #endif
sc_cons(
+ #ifdef apollo
+ sc_cstringtostring( "Domain/OS" ),
+ #else /* ! apollo */
+ #ifdef SPARC
+ #ifdef sun
+ sc_cstringtostring( "SunOS" ),
+ #else
+ sc_cstringtostring( "SparcOS" ),
+ #endif /* sun */
+ #else /* ! SPARC */
+ #ifdef SUN3
+ sc_cstringtostring( "SunOS" ),
+ #else
+ #ifdef SYSV
+ sc_cstringtostring( "System V.3.2" ),
+ #else
sc_cstringtostring( "ULTRIX" ),
+ #endif /* SYSV */
+ #endif /* SUN3 */
+ #endif /* SPARC */
+ #endif /* apollo */
sc_cons(
FALSEVALUE,
EMPTYLIST
*** /tmp/,RCSt1a27560 Fri Nov 9 17:27:16 1990
--- scrt/signal.c Fri Nov 9 14:06:25 1990
***************
*** 49,54 ****
--- 49,57 ----
#include "apply.h"
#include "signal.h"
#include "/usr/include/signal.h"
+ #ifdef apollo
+ #include <apollo/base.h>
+ #endif
extern TSCP scrt4_onsignal2();
***************
*** 118,124 ****
--- 121,131 ----
}
else {
/* Signal must be defered */
+ #ifdef SYSV
+ sighold( signal );
+ #else
sigblock( 1<<signal );
+ #endif
pendingsignals = pendingsignals | (1<<signal);
if (gcinprogress == 0) sc_pendingsignals = 1;
}
***************
*** 150,162 ****
/* Send the pending signals and exit the critical section */
sc_pendingsignals = 0;
self = getpid();
oldmask = sigblock( -1 ) & ~pendingsignals;
for (i = 0; i < 32; i++)
! if (pendingsignals & (1<<i)) kill( self, i );
pendingsignals = 0;
sc_mutex = 0;
sigsetmask( oldmask );
!
/* Apply the when-unreferenced procedures */
while (freed != EMPTYLIST) {
object_procedure = PAIR_CAR( freed );
--- 157,178 ----
/* Send the pending signals and exit the critical section */
sc_pendingsignals = 0;
self = getpid();
+ #ifndef SYSV
oldmask = sigblock( -1 ) & ~pendingsignals;
+ #endif
for (i = 0; i < 32; i++)
! if (pendingsignals & (1<<i)) {
! #ifdef SYSV
! sigrelse( i );
! #endif
! kill( self, i );
! }
!
pendingsignals = 0;
sc_mutex = 0;
+ #ifndef SYSV
sigsetmask( oldmask );
! #endif
/* Apply the when-unreferenced procedures */
while (freed != EMPTYLIST) {
object_procedure = PAIR_CAR( freed );
***************
*** 186,192 ****
int sig, code;
struct sigcontext *scp;
{
! #if (TITAN || (MATHTRAPS == 0))
sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
#endif
--- 202,208 ----
int sig, code;
struct sigcontext *scp;
{
! #if (TITAN || (MATHTRAPS == 0))
sc_error( "???? (in sc_trap_handler)", "Floating point exception", 0 );
#endif
***************
*** 229,234 ****
--- 245,279 ----
C_FIXED( code ));
}
#endif
+ #ifdef apollo
+ if (sig == SIGFPE) {
+ if (code == FPE_INTDIV_TRAP || code == FPE_FLTDIV_FAULT ||
+ code == FPE_FLTDIV_TRAP)
+ /***** divide by zero exception *****/
+ sc_error ("?????", "Divide by zero", 0);
+ if (code == FPE_FLTOVF_TRAP || code == FPE_FLTOVF_FAULT)
+ /***** floating point overflow *****/
+ sc_error ("?????", "Overflow", 0);
+ if (code == FPE_FLTUND_FAULT || code == FPE_FLTUND_TRAP)
+ /***** floating point underflow *****/
+ sc_error ("?????", "Underflow", 0);
+ sc_error ("?????", "Floating point exception: ~s", 1,
+ C_FIXED( code ));
+ }
+ else if (sig == SIGAPOLLO) {
+ status_$t status;
+ char *subsys, *module, *error;
+ short lsubsys, lmodule, lerror;
+ char buffer[256];
+
+ status.all = code;
+ error_$find_text(status, &subsys, &lsubsys, &module, &lmodule,
+ &error, &lerror);
+ sprintf(buffer, "%.*s (%.*s/%.*s)", lerror, error,
+ lsubsys, subsys, lmodule, module);
+ sc_error("?????", buffer, 0);
+ }
+ #endif
/***************************************
other possibly recoverable exceptions
***************
*** 391,397 ****
sc_mathtraps() {
signal(SIGFPE, sc_trap_handler);
! #if MIPS
signal(SIGTRAP, sc_trap_handler);
#endif
}
--- 436,442 ----
sc_mathtraps() {
signal(SIGFPE, sc_trap_handler);
! #ifdef MIPS
signal(SIGTRAP, sc_trap_handler);
#endif
}
*** /tmp/,RCSt1a27697 Fri Nov 9 17:28:02 1990
--- scsc/makefile-tail Thu Nov 1 08:05:18 1990
***************
*** 46,52 ****
mv Xsccomp.heap sccomp.heap
port:
! make "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
Xsccomp.heap Xmv
install-private:
--- 46,52 ----
mv Xsccomp.heap sccomp.heap
port:
! $(MAKE) "CC = ${CC}" "CFLAGS = ${CFLAGS}" "sccomp = echo" \
Xsccomp.heap Xmv
install-private:
***************
*** 94,100 ****
rdist -c sccomp makefile-tail makefile ${destdir}
all:
! make Xsccomp.heap Xmv
srclinks:
for x in ${scsc} ${scc} ${scsch}; \
--- 94,100 ----
rdist -c sccomp makefile-tail makefile ${destdir}
all:
! $(MAKE) Xsccomp.heap Xmv
srclinks:
for x in ${scsc} ${scc} ${scsch}; \
*** /tmp/,RCSt1a27954 Fri Nov 9 17:29:14 1990
--- xlib/makefile Thu Nov 1 08:05:21 1990
***************
*** 91,97 ****
rm -f *.o scixl scxl.a hello puzzle clear
all:
! make scixl scxl.a
gensource:
! make ${xwssc} ${xwsc}
--- 91,97 ----
rm -f *.o scixl scxl.a hello puzzle clear
all:
! $(MAKE) scixl scxl.a
gensource:
! $(MAKE) ${xwssc} ${xwsc}davide@maverick.cad.mcc.com (David Eckelkamp) (11/13/90)
*** /dev/null Fri Nov 9 17:25:01 1990
--- APOLLO Sun Nov 4 11:59:41 1990
***************
*** 0 ****
--- 1,36 ----
+ #
+ # This is the header file for constructing make files for Apollo 3000
+ # series processors (DN3000, DN3500, DN4000, DN4500).
+ #
+
+ .SUFFIXES:
+ .SUFFIXES: .o .c .sc .s .asm .bin
+
+ # Processor name:
+
+ cpu = APOLLO
+
+ # Default flags to use when invoking the C compiler.
+
+ OPT = -O
+ CFLAGS = $(OPT) -A cpu,3000 -A sys,bsd4.3
+ CC = cc
+
+ # Assembly language object files.
+
+ Aruntime = apollo.o
+
+ # The assembler does not normally come with Domain/OS. If you don't have the
+ # assembler, then you can just use the apollo.o file that is supplied.
+ ASM = /usr/apollo/bin/asm
+ AFLAGS = -nl -dba
+
+ # Profiled library
+
+ Plib = # libsc_p.a
+
+ # Heap size in megabytes for the compiler.
+
+ scheapmb = 8 -scl 40
+
+ # End of APOLLO header.
*** /dev/null Fri Nov 9 17:25:04 1990
--- I386 Sun Nov 4 11:52:02 1990
***************
*** 0 ****
--- 1,29 ----
+ #
+ # This is the header file for constructing make files for I386 processors.
+ #
+
+ .SUFFIXES:
+ .SUFFIXES: .o .c .sc .s .u
+
+ # Processor name:
+
+ cpu = I386
+
+ # Default flags to use when invoking the C compiler.
+
+ CFLAGS = -O -DSYSV
+ CC = gcc
+
+ # Assembly language object files.
+
+ Aruntime = i386.o
+
+ # Profiled library
+
+ Plib =
+
+ # Heap size in megabytes for the compiler.
+
+ scheapmb = 4 -scl 40
+
+ # End of I386 header.
*** /dev/null Fri Nov 9 17:25:07 1990
--- PRISM Sun Nov 4 11:59:45 1990
***************
*** 0 ****
--- 1,36 ----
+ #
+ # This is the header file for constructing make files for Apollo 10000
+ # series processors.
+ #
+
+ .SUFFIXES:
+ .SUFFIXES: .o .c .sc .s .asm .bin
+
+ # Processor name:
+
+ cpu = PRISM
+
+ # Default flags to use when invoking the C compiler.
+
+ OPT = -O
+ CFLAGS = $(OPT) -A cpu,a88k -A sys,bsd4.3
+ CC = cc
+
+ # Assembly language object files.
+
+ Aruntime = prism.o
+
+ # The assembler does not normally come with Domain/OS. If you don't have the
+ # assembler, then you can just use the prism.o file that is supplied.
+ ASM = /sr/apollo/bin/asm
+ AFLAGS = -dba
+
+ # Profiled library
+
+ Plib =
+
+ # Heap size in megabytes for the compiler.
+
+ scheapmb = 8 -scl 40
+
+ # End of PRISM header.
*** /dev/null Fri Nov 9 17:25:10 1990
--- SPARC Sun Nov 4 11:52:12 1990
***************
*** 0 ****
--- 1,29 ----
+ #
+ # This is the header file for constructing make files for SPARC processors.
+ #
+
+ .SUFFIXES:
+ .SUFFIXES: .o .c .sc .s .u
+
+ # Processor name:
+
+ cpu = SPARC
+
+ # Default flags to use when invoking the C compiler.
+
+ CFLAGS = -g
+ CC = cc
+
+ # Assembly language object files.
+
+ Aruntime = sparc.o
+
+ # Profiled library
+
+ Plib =
+
+ # Heap size in megabytes for the compiler.
+
+ scheapmb = 8 -scl 40
+
+ # End of SPARC header.
*** /dev/null Fri Nov 9 17:25:11 1990
--- SUN3 Mon Nov 5 11:42:51 1990
***************
*** 0 ****
--- 1,29 ----
+ #
+ # This is the header file for constructing make files for the Sun3
+ #
+
+ .SUFFIXES:
+ .SUFFIXES: .o .c .sc .s
+
+ # Processor name:
+
+ cpu = SUN3
+
+ # Default flags to use when invoking the C compiler.
+
+ CFLAGS = -O
+ CC = cc
+
+ # Assembly language object files.
+
+ Aruntime = sun3.o
+
+ # Profiled library
+
+ Plib =
+
+ # Heap size in megabytes for the compiler.
+
+ scheapmb = 8 -scl 40
+
+ # End of Sun3 header.
*** /dev/null Fri Nov 9 17:25:47 1990
--- scrt/apollo.asm Thu Nov 1 08:02:47 1990
***************
*** 0 ****
--- 1,229 ----
+ * apollo.asm - Apollo specific module for DEC's Scheme->C
+ *
+ * This file implements the assembly language part of the Apollo port,
+ * specifically for the DN3000 and DN4000 series, that is, depending on
+ * the M68020 CPU and M68881 FPP.
+ *
+ * Included are all the necessary math routines to catch integer overflow.
+ *
+ * This file is written for PIC (Position Independent Code), to build
+ * a shared library.
+ *
+ * Ray Lischner (uunet!mntgfx!lisch)
+ * 26 April 1990
+
+ module sc_apollo
+ cpu 68020,68881
+ sri 68020
+
+ entry sc_setregs
+ entry sc_regs
+ entry sc_iplus
+ entry sc_idifference
+ entry sc_inegate
+ entry sc_itimes
+
+ data
+
+ * set up jump tables for calling PIC routines
+ data_start equ *
+
+ sc_iplus lea data_start,a0
+ jmp.l sc$iplus
+ sc_idifference lea data_start,a0
+ jmp.l sc$idifference
+ sc_inegate lea data_start,a0
+ jmp.l sc$inegate
+ sc_itimes lea data_start,a0
+ jmp.l sc$itimes
+
+ * set up transfer address for external PIC routines
+ extern sc_makefloat64
+ sc$makefloat64 ac sc_makefloat64
+
+ text
+
+ ***********************************************************************
+ * void sc_setregs(int* a6, int* a7)
+ * Apollo's longjmp() checks to see if the jump is backwards in the stack.
+ * If not, it assumes that something is wrong and ungracefully terminates
+ * the program. Since we don't want this to happen, we need to fake
+ * out Domain/OS. This is done by setting the stack pointer (a7) and
+ * frame pointer (a6) to the destination frame, thus circumventing
+ * longjmp's checks.
+ *
+ * To accomplish this takes some clever tricks. First, we need to know
+ * how the stack is layed out:
+ *
+ * (lower addresses)
+ * +----------------------------+
+ * A7 | local storage ... |
+ * +----------------------------+
+ * A6 | link to previous frame |
+ * +----------------------------+
+ * | return address |
+ * +----------------------------+
+ * | arguments pushed by caller |
+ * +----------------------------+
+ * (higher addresses)
+ * Note that we are ignoring floating point control blocks.
+ *
+ * The caller pushes the desired values for A7 and A6. On entry to sc_setregs(),
+ * A6 points to the caller's frame, and A7 points to the return address.
+ * We can retrieve the caller's arguments by dereferencing a7: the second
+ * argument is in 8(a7), and the first is in 4(a7). We can just copy
+ * them into the registers we want, but first we need to save the return
+ * address before we lose the pointer to it. It is saved in A0, at the
+ * same time we load A6 and A7. Clever, isn't it? After getting the new
+ * register values, we know that the caller will try to pop the
+ * arguments off the stack by adding 8 to A7. We circumvent this by
+ * subtracting 8 now.
+
+ sc_setregs procedure "sc_setregs",nocode
+ movem.l (a7),a0/a6-a7
+ subq.l #8,a7
+ jmp (a0)
+
+ ***********************************************************************
+ * void sc_regs(int regs[12])
+ * sc_regs returns the values of a1-a4, d0-d7 in the caller supplied buffer.
+ * These are the "callee" save registers that need to be examined during
+ * garbage collection.
+
+ sc_regs procedure "sc_regs",#-4
+ move.l 8(a6),a0 * a0 := ®s[0]
+ movem.l d0-d7/a1-a4,(a0) * save the interesting registers
+ return sc_regs
+
+ ***********************************************************************
+ * The following routines are for doing arithmetic on tagged numbers.
+ * The input arguments are tagged integers, that is, integers shifted
+ * left by two bits. (Except for sc_itimes, where only the second
+ * argument, b, is shifted.) This makes it easier to check for overflow,
+ * but we must unshift the values before calling sc_makefloat64().
+ *
+ * When the result of any operation overflows, the operands are converted
+ * to floating point, and the operation is repeated. The floating point
+ * result is then passed to sc_makefloat64() to produce a float object
+ * to return.
+
+ * int sc_iplus(int a, int b)
+ * returns the integer sum, a + b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead.
+
+ sc$iplus procedure "sc_iplus",#0,a5
+ move.l a0,a5
+ * add the arguments
+ move.l 8(a6),d0
+ move.l 12(a6),d1
+ add.l d1,d0
+ * if the operation overflows, we know to use floating point
+ bvc 1$
+
+ * otherwise, convert to floating point and add
+ move.l 8(a6),d0
+ asr.l #2,d0
+ fmove.l d0,fp0
+ * note that d1 still contains "b"
+ asr.l #2,d1
+ fmove.l d1,fp1
+ fadd fp1,fp0
+ * pass the floating point sum to sc_makefloat64
+ fmove.d fp0,-(sp)
+ move.l sc$makefloat64,a0
+ jsr (a0)
+ addq.l #8,sp
+
+ 1$ return sc$iplus
+
+
+ * int sc_idifference(int a, int b)
+ * returns integer difference, a - b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead.
+ *
+
+ sc$idifference procedure "sc_idifference",#0,a5
+ move.l a0,a5
+ * subtract the arguments
+ move.l 8(a6),d0
+ move.l 12(a6),d1
+ sub.l d1,d0
+ * if the operation overflows, we know to use floating point
+ bvc 1$
+
+ * otherwise, convert to floating point and subtract
+ move.l 8(a6),d0
+ asr.l #2,d0
+ fmove.l d0,fp0
+ * note that d1 still contains "b"
+ asr.l #2,d1
+ fmove.l d1,fp1
+ fsub fp1,fp0
+ * pass the floating point sum to sc_makefloat64
+ fmove.d fp0,-(sp)
+ move.l sc$makefloat64,a0
+ jsr (a0)
+ addq.l #8,sp
+
+ 1$ return sc$idifference
+
+ * int sc_inegate(int a)
+ * returns integer negation, -a, where a is the integer
+ * argument, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( -(double)a) instead.
+ *
+
+ sc$inegate procedure "sc_inegate",#0,a5
+ move.l a0,a5
+ * negate the argument
+ move.l 8(a6),d0
+ move.l d0,d1
+ neg.l d0
+ * if the operation overflows, we know to use floating point
+ bvc 1$
+
+ * otherwise, convert to floating point and negate
+ asr.l #2,d1
+ fmove.l d1,fp1
+ fneg fp1,fp0
+ * pass the floating point sum to sc_makefloat64
+ fmove.d fp0,-(sp)
+ move.l sc$makefloat64,a0
+ jsr (a0)
+ addq.l #8,sp
+
+ 1$ return sc$inegate
+
+ * sc_itimes(int a, int b)
+ * returns integer procuct, a * b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead.
+ * Unlike the previous arithmetic functions, only "b" has been shifted.
+
+ sc$itimes procedure "sc_itimes",#0,a5
+ move.l a0,a5
+ * multiply the arguments
+ move.l 8(a6),d0
+ move.l 12(a6),d1
+ muls.l d1,d0
+
+ * if the operation overflows, we know to use floating point
+ bvc 1$
+
+ * otherwise, convert to floating point and multiply
+ fmove.l 8(a6),fp0
+ * note that d1 still contains "b"
+ asr.l #2,d1
+ fmove.l d1,fp1
+ fmul fp1,fp0
+ * pass the floating point sum to sc_makefloat64
+ fmove.d fp0,-(sp)
+ move.l sc$makefloat64,a0
+ jsr (a0)
+ addq.l #8,sp
+
+ 1$ return sc$itimes
+
+ end
*** /dev/null Mon Nov 12 09:28:29 1990
--- scrt/apollo.o.uu Mon Nov 12 09:26:54 1990
***************
*** 0 ****
--- 1,69 ----
+ begin 444 apollo.o
+ M 9< "28WDLH DT '0 L@ X 0 ! #) "P @
+ M 0 (?@ "YT97AT "!J @:@ $$ !J
+ M @ " N=6YW:6YD @JP (*L > JP B*
+ M ' @+F1A=&$ 0 $ "P
+ M( @"YB;&]C:W, $ + ! "P '@ #) "- 0 # N
+ M;&EN97, ! @P 0(, D@ !00 P +G-Y;6)O
+ M;', 0*> $"G@ I8 66 , "YR=V1I $%
+ M- !!30 X (+ "/@ 8 ! N;6ER
+ M &@ "&0 ( +G-R:0 P
+ M A^ " $S7P0!1CT[03E;__"!N A(T![_3EY.=4Y6
+ M O#2I(("X ""(N S0@6@ "(@+@ (Y(#R $ Y('R 4" \@ $(O(G= @
+ M;0 H3I!0CRIN__Q.7DYU3E8 "\-*D@@+@ ((BX #)"!: (B N CD@/(
+ M0 #D@?(!0(#R 0H\B=T "!M "A.D%"/*F[__$Y>3G5.5@ +PTJ2" N @B
+ M $2 : &.2!\@% @/( !!KR)W0 (&T *$Z04(\J;O_\3EY.=4Y6 O#2I(
+ M("X ""(N Q, 0@ : 'O(N0 ".2!\@% @/( !"/R)W0 (&T *$Z04(\J
+ M;O_\3EY.=0 "!J ! @0 !X @:@ @# @
+ M @; ! ! /____P (' ^ 2 #____\ "!_@ /@$@
+ M _____ @CP #(!( /____P ()N \ 2 #____\ 0 ! @
+ M 4 !P #H : +@ > " $ $"# ! IX (&H $ , %*
+ M"O-, !*@0 5P @ / 0 "P ! 0
+ M $ (" * $^ ( $ ( , $ 0! "
+ M @ "@ !(0 " * ! $ # " ! ' 0 @( H
+ M 0$ @ % 0 #X P !@ 0 "H$ (" *
+ M #B ( !X $ ^ , !6 $ !%! " @ "@ R0 "
+ M H ! ,@ # E ! 8 0 @( *P @ ,@
+ M 0 #P P ,8 0 '@; (@O+VIE;&QI;W1T+VQO8V%L7W5S97(O
+ M9VYU+G-R8RYP<F]J+V1E8RUS8VAE;64O<V-R="]A<&]L;&\N87-M '-C7V%P
+ M;VQL;P!S8U]S971R96=S '-C7W)E9W, <V-?:7!L=7, <V-?:61I9F9E<F5N
+ M8V4 <V-?:6YE9V%T90!S8U]I=&EM97, @0 0 !\ $A,2$Q(3$D./ H$ $ !2
+ MB 0$A&/ 8$ $ != (@ $A*)$H\"@0 0 ', B 3(1(2(3(2$2(1$B(2$A&)
+ M(8\$@0 0 ), B 3(1(2(3(2$2(1$B(2$A&)(8\$@0 0 +( B 3(1(1(3(1
+ M$B(2$A&)(8\$@0 0 ,T B 3(1(2,C(C$1(B$A(1B2&/!( 7 $ !2
+ M ! 514 0 %( 3X @ 1@ %P ! 70 0 & 5
+ M $ != $A ( H $8 !< 0 ', $ "*%0
+ M ! <P ! 0 " 4 !& 7 $ "3 ! JA4 0 ),
+ M .( @ '@ 1@ %P ! L@ 0 ,45 $ "R #)
+ M ( "@ $8 !< 0 ,T $ #C%0 ! S0 K "
+ MR !& 7 $ ! ! XQ8 !$ 0 !T R $ 6
+ M 04 $ ? ,@! %@ #X ! (0 #( 0 * !8
+ M\0 0 ", R $ % 6 .8 $ E ,@! !X %@ #:
+ M ! *@ #( 0 H !8 TP 0 %( R # 6 ,@
+ M$ != ,@ P @ %@ "Z ! <P #( , 8 !8 K0 0
+ M ), R # 5@ 6 *8 $ "R ,@ P )0 %@ "; !
+ MS0 #( , #& !@ &P "(9&%T85]S=&%R= !S8U]I<&QU<P!S8U]I
+ M9&EF9F5R96YC90!S8U]I;F5G871E '-C7VET:6UE<P!S8R1M86ME9FQO870V
+ M- !S8U]S971R96=S '-C7W)E9W, <V,D:7!L=7, <V,D:61I9F9E<F5N8V4
+ M<V,D:6YE9V%T90!S8R1I=&EM97, $ "Q!^O_^3OD (' 0?K_
+ M]$[Y "!_D'Z_^I.^0 @CQ!^O_@3OD ()N # @ ! X)"B*%
+ MYP8 $ ( " @ ! $ ! 0 (*L !@ & ""O 8
+ M!@ @M0 & 8 (+D !@ & ""] 8 !@ @P0 & 8 (,4
+ M !@ & $ 2@ X !@ ! $X 0 8 0!2 !@ & $ 5@ H
+ M!@ !!38 * 8 05$ !@ & $%3@ 8 !@ !!5@ & 8 05B
+ M !@ & $%9@ !P !BYF:6QE &/_^ !G 6%P;VQL;RYA<VT
+ M 2 "!J ! "0" 0 ( '-C
+ M7W)E9W, "!L ! "0" 0 0 "YT97AT "!
+ MJ ! # 0 00 "YU;G=I;F0 ""K " # 0
+ M '@ !P "YD871A $ # # 0 "P
+ M "YB;&]C:W, $ + $ # 0 > ! "YL
+ M:6YE<P $"# % # 0 )( "YS>6UB;VQS $"
+ MG@ & # 0 I8 "YR=V1I $%- ' # 0
+ M #@ !@ "YM:7( ( # 0 !H
+ M "YS<FD ) # 0 P '-C
+ M7VEP;'5S $ # 0" = $ "@ # 0" L $
+ M% # 0" W $ '@ # 0" !! "
+ M %!!4TT <V-?87!O;&QO '-C7W-E=')E9W, <V-?:61I9F9E<F5N8V4 <V-?
+ A:6YE9V%T90!S8U]I=&EM97, <V-?;6%K969L;V%T-C0
+
+ end
*** /dev/null Fri Nov 9 17:26:24 1990
--- scrt/prism.asm Thu Nov 1 08:02:50 1990
***************
*** 0 ****
--- 1,387 ----
+ * prism.asm - Apollo Prism (DN10000) specific module for DEC's Scheme->C
+ *
+ * This file implements the assembly language part of the Prism port,
+ * specifically for the DN10000.
+ *
+ * Included are all the necessary math routines to catch integer overflow.
+ *
+ * NOTE: Don't even try to read this file if you do not understand
+ * how an Apollo Prism (also called an AT, for Advanced Technology;
+ * perhaps Apollo thinks the Prism is as good as an IBM PC AT :-) works.
+ * I have tried to optimize the parallel operations, such as branch and
+ * call shadows, and combining integer and floating point operations.
+ * (The former are common; the latter are rare in this file.)
+ *
+ * The sematics of b.sa are completely different from b.sn, and the
+ * subtle differences are too lengthy to discuss here. Read the
+ * various Apollo manuals, such as the AT Assembler Reference and
+ * the AT Technical Reference.
+ *
+ * Apollo's setjmp/longjmp do not permit jumps to random locations in the
+ * stack, so we must write our own. On the DN3000 (M68K), we can get away
+ * with simply altering the stack and frame pointers (A6 and A7) before
+ * calling longjmp, but on the Prism this does not work because longjmp
+ * only jumps to a valid stack frame. I tried modifying call/cc to
+ * restore the stack and registers before calling longjmp(), but this
+ * does not work because it changes the data base register, which messes
+ * up the call to longjmp. The simplest solution is to reimplemen]t
+ * setjmp and longjmp.
+ *
+ * Another reason to write our own setjmp/longjmp is to make sure all
+ * the registers are saved properly. The standard jmp_buf does not have
+ * enough room to save all the needed registers.
+ *
+ * Ray Lischner (uunet!mntgfx!lisch)
+ * 1 May 1990
+
+ module sc_prism
+
+ export.f prism_stack_frame
+ export.p sc_longjmp
+ export.f sc_setjmp
+ export.p sc_regs
+ export.f sc_iplus
+ export.f sc_idifference
+ export.f sc_inegate
+ export.f sc_itimes
+
+ import.f sc_makefloat64
+ import.f sigblock
+ import.f sigsetmask
+
+ data
+
+ * set up ECBs for all the functions that need one
+ data_frame equ *
+
+ sc_setjmp procedure ok
+ .0 = sc$setjmp ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ sc_longjmp procedure ok
+ .0 = sc$longjmp ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ sc_idifference procedure ok
+ .0 = sc$idifference ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ sc_inegate procedure ok
+ .0 = sc$inegate ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ sc_iplus procedure ok
+ .0 = sc$iplus ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ sc_itimes procedure ok
+ .0 = sc$itimes ; get the relocatable address of the routine
+ .1 = .sf ; save the old stack frame
+ .2 = #data_frame ; get the relocatable data frame
+ b.sa [.0] ; branch to the real routine
+ [--.sf,#16] = .1 ; push the old .SF onto the stack
+
+ * jump table for the ECBs
+ sc$setjmp data.l sc$$setjmp
+ sc$longjmp data.l sc$$longjmp
+ sc$idifference data.l sc$$idifference
+ sc$inegate data.l sc$$inegate
+ sc$iplus data.l sc$$iplus
+ sc$itimes data.l sc$$itimes
+
+ * relocation table for the external functions
+ sc$makefloat64 data.l sc_makefloat64
+ sig$setmask data.l sigsetmask
+ sig$block data.l sigblock
+ proc
+
+ ***********************************************************************
+ * int prism_stack_frame(void)
+ * Return the caller's stack frame pointer. See the STACKPTR macro
+ * in heap.h for how this is called.
+
+ prism_stack_frame procedure ok
+ b.sa [.return]
+ .0 = .sf
+
+
+ ***********************************************************************
+ * int sc_setjmp(jmp_buf buf)
+ * Save the current signal mask, processor status words, and preserved
+ * registers in the caller-supplied buffer, and return zero.
+
+ sc$$setjmp procedure name="sc_setjmp",return=save,stack=(),save=1$
+ [.sf,4] = .4
+ [.sf,8] = .return
+ [.sf,12] = .10
+ .10 = .2
+ using .10, data_frame
+ 1$ .0 = .ipsw ; and the processor status words
+ [.4++] = .0
+ .0 = .fppsw
+ [.4++] = .0
+ .0 = [.sf,12] ; old value of .10
+ [.4++] = .0
+ [.4++] = .11
+ [.4++] = .12
+ [.4++] = .13
+ [.4++] = .14
+ [.4++] = .15
+ [.4++] = .16
+ [.4++] = .17
+ [.4++] = .18
+ [.4++] = .19
+ [.4++] = .20
+ [.4++] = .21
+ [.4++] = .return
+ .0 = [.sf]
+ [.4++] = .0
+
+ .3 = sig$block ; and the current signal mask
+ .return = call.sa [.3] ; sigblock(0)
+ .4 = .null
+ .4 = [.sf,4]
+ [.4++] = .0
+
+ .10 = [.sf,12] ; restore the saved registers
+ .return = [.sf,8]
+ .0 = .null
+ b.sa [.return] ; return(0)
+ .sf = [.sf]
+
+ drop .10
+ endp
+
+ * void longjmp(jmp_buf buf, int rtn)
+ * Jump to the location saved by a previous call to setjmp(), such that
+ * it looks to the caller of setjmp() as though setjmp returned "rtn".
+ * If "rtn" is zero, one is returned.
+
+ sc$$longjmp procedure name="sc_longjmp",return=save,stack=(),save=1$
+ [.sf,8] = .return
+ using .2, data_frame
+ 1$ .cc = .5
+ .0 = [.4++]
+ bnz.sf 2$ ; make sure the return value is non-zero
+ .5 = #1
+ 2$ .ipsw = .0
+ .0 = [.4++]
+ .fppsw = .0
+ .10 = [.4++]
+ .11 = [.4++]
+ .12 = [.4++]
+ .13 = [.4++]
+ .14 = [.4++]
+ .15 = [.4++]
+ .16 = [.4++]
+ .17 = [.4++]
+ .18 = [.4++]
+ .19 = [.4++]
+ .20 = [.4++]
+ .21 = [.4++]
+ .0 = [.4++]
+ [.sf,8] = .0 ; save the return PC
+ .0 = [.4++]
+ [.sf] = .0 ; save .sf
+ [.sf,4] = .5 ; save return value
+
+ .3 = sig$setmask ; restore the signal mask
+ .return = call.sa [.3]
+ .4 = [.4]
+
+ .0 = [.sf,4] ; return the user-supplied "rtn"
+ .return = [.sf,8]
+ b.sa [.return]
+ .sf = [.sf]
+ endp
+
+ ***********************************************************************
+ * void sc_regs(int regs[12])
+ * sc_regs stores the values of .10 - .21 in the caller supplied buffer.
+ * These are the "callee" save registers that need to be examined during
+ * garbage collection.
+
+ sc_regs procedure ok
+ [.4++] = .10
+ [.4++] = .11
+ [.4++] = .12
+ [.4++] = .13
+ [.4++] = .14
+ [.4++] = .15
+ [.4++] = .16
+ [.4++] = .17
+ [.4++] = .18
+ [.4++] = .19
+ [.4++] = .20
+ b.sa [.return]
+ [.4] = .21
+ endp
+
+ ***********************************************************************
+ * The following routines are for doing arithmetic on tagged numbers.
+ * The input arguments are tagged integers, that is, integers shifted
+ * left by two bits. (Except for sc_itimes, where only the second
+ * argument, b, is shifted.) This makes it easier to check for overflow,
+ * but we must unshift the values before calling sc_makefloat64().
+ *
+ * When the result of any operation overflows, the operands are converted
+ * to floating point, and the operation is repeated. The floating point
+ * result is then passed to sc_makefloat64() to produce a float object
+ * to return.
+
+
+ * int sc_iplus(int a, int b)
+ * returns the integer sum, a + b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a + (double)b ) instead.
+
+ sc$$iplus procedure name="sc_iplus",return=save,stack=(),save=1$
+ [.sf,8] = .return
+ * add the arguments
+ 1$ .0.cc = .4 + .5 ; try adding the arguments as integers
+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set
+ bnv.sf 2$ ; return if the integer operation worked
+ .5 = .5 SHRA #2 ; otherwise keep working
+ .fs0.i = .5 ; convert the integers to floating point
+ .fs1.i = .4
+ .fd8 = float(.fs1.i)
+ .fd0 = float(.fs0.i)
+ * get ready to call makefloat64, while adding the operands
+ .3 = sc$makefloat64, .fd8 += .fd0
+ .return = call.sn [.3] ; call sc_makefloat64()
+ nop
+ .return = [.sf,8] ; pop the return PC
+
+ 2$ b.sa [.return] ; return
+ .sf = [.sf] ; restore the old .SF
+ endp
+
+
+ * int sc_idifference(int a, int b)
+ * returns integer difference, a - b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a - (double)b ) instead.
+
+ sc$$idifference procedure ok,name="sc_idifference"
+ [.sf,8] = .return
+ * subtract the arguments
+ 1$ .0.cc = .4 - .5 ; try subtracting the arguments as integers
+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set
+ bnv.sf 2$ ; return if the integer operation worked
+ .5 = .5 SHRA #2 ; otherwise keep working
+ .fs0.i = .5 ; convert the integers to floating point
+ .fs1.i = .4
+ .fd8 = float(.fs1.i)
+ .fd0 = float(.fs0.i)
+ * get ready to call makefloat64, while subtracting the operands
+ .3 = sc$makefloat64, .fd8 -= .fd0
+ .return = call.sn [.3] ; call sc_makefloat64()
+ nop
+ .return = [.sf,8] ; pop the return PC
+
+ 2$ b.sa [.return] ; return
+ .sf = [.sf] ; restore the old .SF
+ endp
+
+ * int sc_inegate(int a)
+ * returns integer negation, -a, where a is the integer
+ * argument, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( -(double)a) instead.
+
+ sc$$inegate procedure ok,name="sc_inegate"
+ [.sf,8] = .return
+ * negate the argument
+ 1$ .0.cc = -.4 ; try negating the argument as an integer
+ .4 = .4 SHRA #2 ; wait 1 cycle until CCs set
+ bnv.sf 2$ ; return if the integer operation worked
+ .fs0.i = .4 ; otherwise keep working
+ .fd8 = float(.fs0.i) ; convert the argument to floating point
+ * get ready to call makefloat64, while negating the argument
+ .3 = sc$makefloat64, .fd8 = -.fd8
+ .return = call.sn [.3] ; call sc_makefloat64()
+ nop
+ .return = [.sf,8] ; pop the return PC
+
+ 2$ b.sa [.return] ; return
+ .sf = [.sf] ; restore the old .SF
+ endp
+
+ * sc_itimes(int a, int b)
+ * returns integer procuct, a * b, where a and b are the two
+ * integer arguments, unless integer overflow occurs, then returns
+ * (unsigned int) sc_makefloat64( (double)a * (double)b ) instead.
+ * Unlike the previous arithmetic functions, only "b" has been shifted.
+ *
+ * This is a pain on a Prism because we need to use the floating
+ * point unit for the integer multiply, and that means we cannot
+ * set the integer condition codes. Instead, we do a normal
+ * floating point multiply and explicitly check the result to see
+ * if it fits into an integer. If not, we divide by 4 to get the
+ * true result. Note that this does not affect the precision
+ * of the result.
+
+ sc$$itimes procedure name="sc_itimes",return=save,stack=(),save=1$
+ [.sf,8] = .return
+ 1$ .fs0.i = .4 ; load floating point registers for the
+ .fs1.i = .5 ; multiplication
+ .fd8 = float(.fs0.i)
+ .fd2 = float(.fs1.i)
+ * do the multiply; at the same time, load sc_makefloat64's address, to
+ * get ready for calling it, in case the multiply overflows
+ .3 = sc$makefloat64, .fd8 *= .fd2
+
+ * The floating point constants do not change, so we can put them in
+ * the shared text segment. Change the address base to .PC, so we
+ * use PC-relative addressing.
+ drop .2
+
+ * look for overflow by comparing with the maximum allowable integer
+ .fd2 = maxint ; get maxint
+ .fcc = .fd8 ? .fd2
+ bfgt.sf 2$ ; see if the result fits into an integer
+ .fd2 = minint.fd
+ .fcc = .fd8 ? .fd2
+ bflt.sf 2$
+
+ .fs0.i = round(.fd8) ; yes, so convert it to an integer
+ b.sa 3$ ; and return
+ .0 = .fs0.i
+
+ 2$ .fd0 = four
+ .fd8 /= .fd0 ; get the real floating point value
+ .return = call.sn [.3] ; call sc_makefloat64()
+ nop
+ .return = [.sf,8] ; pop the return PC
+
+ 3$ b.sa [.return] ; return
+ .sf = [.sf] ; restore the old .SF
+
+ * constant value for the division, above
+ four data.fd 4.0
+
+ * maximum and minimum possible integer, for comparison, above
+ maxint data.fd 2147483644.0
+
+ * The assembler seems to ignore the sign of a floating point constant.
+ * A Prism uses IEEE format, so the smallest possible integer
+ * is pretty easy to write in hexadecimal.
+ *minint data.fd -2147483648.0
+ minint data.q h'C1E00000, h'00000000
+ endp
+
+ end
*** /dev/null Mon Nov 12 09:28:30 1990
--- scrt/prism.o.uu Mon Nov 12 09:26:39 1990
***************
*** 0 ****
--- 1,82 ----
+ begin 444 prism.o
+ M 90 ""8]YI@ K0 )0 L@ H 0 ! $R * (
+ M$ "YT97AT @!@ ( 8 +8 !@
+ M ! @ " N=6YW:6YD (!%@ " 18 < !%@ GX
+ M ' 0 @+F1A=&$ $ ! * 3( */@ "0
+ M$ 0"YM:7( < %: @ N
+ M<W)I # !80 ( +F)L;V-K
+ M<P $ "@ ! H U 60 *F !0 , "YL:6YE<P ! #
+ M\ 0 _ $8 (X # N<WEM8F]L<P 0!0@ $ 4(
+ M P )# %A 7(!]HEP $:M< "&E7 P1
+ M0B ??!\@ #@$$@3\'R( .0" #@$$@1@%P ,. 02!#ED$@0YA!($.:02!#G$
+ M$@0YY!($.@02!#HD$@0Z1!($.F02!#J$$@0ZI!($.L02!& 7 X!!($8&H
+ MF"+ ,0GR ?8)< !#@$$@1A5P ,8M< "! ?(!\D, 68O< &K7 @3Y6 ?
+ M/ 02!"V< (8OP !?!\ #P$$@3\'P( .0" #U$$@0]9!($/802!#VD$@0]
+ MQ!($/>02!#X$$@0^)!($/D02!#YD$@0^A!($/J02!#P$$@1H%P (/ 02!&@7
+ M !HMP $8&( E"+ -@A 8!< !&+7 @D, 68O< #E$$@0Y9!($.802
+ M!#FD$@0YQ!($.>02!#H$$@0Z)!($.D02!#ID$@0ZA!($)# %FJD !JUP (
+ M$ 1@!1""OT0MW /$**_1?R_ 0 Y $ _)\!! #D 023_P ?-CR 09/_ !\V
+ M/ X&( D#*,@@ BQ #$_\ 'V+7 @D, 68O< &K7 @0!&@%$(*_1"W<
+ M \0HK]%_+\! #D 0#\GP$$ .0!!)/_ !\V/(!!D_\ 'S8\ #@8@"0,IR"
+ M "+$ ,3_P ?8M< ""0P !9B]P :M< "! ?: 00@K]$K=P "P3$ #\GP$
+ M .0! )/_ !\V/( X&( D#)<@@@BQ #$_\ 'V+7 @D, 68O< &K7 C\
+ MGP$ .0! /R_ 00 Y $$D_\ 'S8\@ "3_P ?-CP@0>!B ) P3(("[#X < 3$
+ M "3_P ?$[P" BJ< QL/@!DD_\ 'Q.\ @*K' (!,0 )/_ !\V' ((K#
+ M"P3$ #\'R$ .0! .P> "@$Q D_\ 'S ,@@ BQ #$_\ 'V+7 @D, 6
+ M8O< ! $ $'?____ P> " &( %H! '
+ M @!B 1@ @ _^V" ( A0 $( ( /_M@( " +, H "
+ M #_[8" @#' * _^P ( VP " /_L " .L !6
+ M " #_[8" 8!X >! W(!\87O_X)# #@WE'!@'@!H$#<@'QA>_^0D,
+ M.#>4<& > %@0-R ?&%[_T"0P X-Y1P8!X 2! W(!\87O^\)# #@WE'!@
+ M'@ X$#<@'QA>_Z@D, .#>4<& > "@0-R ?&%[_E"0P X-Y1P @!B (
+ M A0 " ,< @#; ( LP " .L ( 0 . #DC
+ M6\;3 ! " @ * ! $ ! !@! $" !@ . /@
+ M !H R #4 ( 4 " & ! 0 * $ /P ! %" , $F/>@! "
+ M0@0 @( P< 0 *P 0 BP ! /0$ ("
+ M +4 $ ! $ 'L 0 #A! " @
+ M "G0 ! 4 ! !G $ RP0 @(
+ M FP 0 % 0 4P ! +4$ (" (\
+ M $ T $ $8 0 "A! " @ ""0 !
+ M A ! E $ >@0 @( =< 0 (P
+ M 0 @ ! %$$ (" &= $ ( $
+ M 0 !(! " @ !:P ! % " 9 $
+ M/ 0 @( 3H 0 !0 @ % ! # $ ("
+ M $' $ 4 ( \ 0 D! " @
+ M T ! % " * $ & 0 @(
+ M )T 0 !0 @ !0 ! P$ (" !K
+ M $ 4 ( 0 &P #<+R]J96QL:6]T="]L;V-A;%]U
+ M<V5R+V=N=2YS<F,N<')O:B]D96,M<V-H96UE+W-C<G0O<')I<VTN87-M '-C
+ M7W-E=&IM< !S8U]L;VYG:FUP '-C7VED:69F97)E;F-E '-C7VEN96=A=&4
+ M<V-?:7!L=7, <V-?:71I;65S '!R:7-M7W-T86-K7V9R86UE '-C7W-E=&IM
+ M< !S8U]L;VYG:FUP '-C7W)E9W, <V-?:7!L=7, <V-?:61I9F9E<F5N8V4
+ M<V-?:6YE9V%T90!S8U]I=&EM97, ($ $ Z !$1$1&/ 8$ $ !! !$1$1&/
+ M 8$ $ !( !$1$1&/ 8$ $ !/ !$1$1&/ 8$ $ !6 !$1$1&/ 8$ $ != !$1
+ M$1&/ 8$ $ !W !&/ 8$ $ "! !$1$2$1$1(1$1$1$1$1$1$1$1$1$1$1(1$1
+ M$1$A$1$1$8\!@0 0 + (1$1$1$1$1(1$1$1$1$1$1$1$1$1$1$1(1$1(1$1
+ M$8\!@0 0 -P $1$1$1$1$1$1$1$1CP&! ! _@ A$1$1$1(2$B(2$1$A$8\!
+ M@0 0 1D (1$1$1$2$A(B$A$1(1&/ 8$ $ $S "$1$1(2(A(1$2$1CP&! ! !
+ M4P 1$A(2,H(( A(2$1$2(A(2(A(2$1$A$8\(@ " 18 $@ & @$
+ M: !( !@ (!'@ 2 8 " 2( $@ & @$F !( !@ (!*@ 2
+ M 8 " 2X $@ & ! > !( !@ 0 'P 2 8 $ " $@ & !
+ MA !( !@ 0 (@ 2 8 $ ", $@ & ! D "0 !@ 0 )0 B
+ M 8 $ "8 (P & ! O@ !( !@ 0 ,( 6 8 $ #& ' & !
+ MR@ !X !@ 0 ,X @ 8 N9FEL90 "+__@ 9P%P<FES
+ M;2YA<VT 5 0 &0 P D @$
+ M $ 20 0 #P P D @$ &
+ M .@ 0 "@ P D @$ ( !S8U]I<&QU<P 0 %
+ M P D @$ * !S8U]R96=S ( I@ 0 D @$
+ M , , 0 P D @$
+ M . )0 0 !0 P D @$ 0
+ M $P ( 8 0 D @$ 2 N=&5X= ( 8
+ M 0 P$ +8 N=6YW:6YD (!%@ @ P$ !P
+ M < N9&%T80 0 P P$ "@ D
+ M N;6ER ! P$ < N<W)I
+ M !0 P$ , N8FQO8VMS 0 *
+ M!@ P$ -0 4 N;&EN97, 0 _ !P P$ $8
+ M N<WEM8F]L<P 0!0@ " P$
+ M ;0 @!S:6=B;&]C:P @
+ M 7@ @ !X<')A<VT <V-?<')I<VT <')I<VU?<W1A8VM?
+ M9G)A;64 <V-?;&]N9VIM< !S8U]S971J;7 <V-?:61I9F9E<F5N8V4 <V-?
+ L:6YE9V%T90!S8U]I=&EM97, <V-?;6%K969L;V%T-C0 <VEG<V5T;6%S:P!?
+
+ end
*** /dev/null Fri Nov 9 17:27:19 1990
--- scrt/sparc-pragma.h Fri Nov 9 14:03:41 1990
***************
*** 0 ****
--- 1,3 ----
+ /* This is the pragma declartion that is necessary to tell the SPARC */
+ /* compiler about the new setjmp routine. */
+ #pragma unknown_control_flow(sc_setjmp)
*** /dev/null Fri Nov 9 17:27:20 1990
--- scrt/sparc.s Sun Nov 4 11:52:56 1990
***************
*** 0 ****
--- 1,106 ----
+ !
+ ! Rules for building continuations on the SPARC:
+ !
+ ! 1 - register windows must be flushed to memory before
+ ! the stack is copied to the heap.
+ !
+ ! 2 - setjmp must save the caller's local and input register
+ ! frames when saving context, because longjmp will not
+ ! have access to the saved stack to fetch the registers
+ ! from their normal resting place.
+ !
+ ! 3 - longjmp must flush register windows so the correct register
+ ! values will be reloaded from memory when execution continues
+ ! on the restored stack.
+ !
+ ! 4 - longjmp must restore the caller's local and input register
+ ! frames because the stack hasn't been restored when longjmp
+ ! is called.
+ !
+
+
+ !
+ ! This misnamed function is responsible for providing the
+ ! top of stack address, via macro STACKPTR, to the continuation
+ ! builder and the heap manager. Because both of these functions
+ ! immediately begin examining the memory on the stack, the register
+ ! windows are flushed to memory so their values will be saved in
+ ! heap allocated continuations and seen by the garbage collector.
+ !
+ .global _sc_processor_register
+ _sc_processor_register:
+ ta 3 ! flush register windows
+ jmp %o7+8 ! return
+ add %sp, 0, %o0 ! return stack pointer
+
+ !
+ ! Save the current environment in a heap allocated continuation.
+ !
+ .global _sc_setjmp
+ _sc_setjmp:
+ st %o6, [%o0 + 0] ! save stack pointer
+ st %o7, [%o0 + 4] ! save continuation pointer
+ st %g1, [%o0 + 8] ! save global registers
+ st %g2, [%o0 + 12] ! these may be allocated for
+ st %g3, [%o0 + 16] ! caller saves registers or
+ st %g4, [%o0 + 20] ! for global values.
+ st %g5, [%o0 + 24]
+ st %g6, [%o0 + 28]
+ st %g7, [%o0 + 32]
+ st %l0, [%o0 + 36] ! save local registers
+ st %l1, [%o0 + 40] ! the sunos setjmp uses
+ st %l2, [%o0 + 44] ! the register windows to
+ st %l3, [%o0 + 48] ! save these, we can't.
+ st %l4, [%o0 + 52]
+ st %l5, [%o0 + 56]
+ st %l6, [%o0 + 60]
+ st %l7, [%o0 + 64]
+ st %i0, [%o0 + 68]
+ st %i1, [%o0 + 72]
+ st %i2, [%o0 + 76]
+ st %i3, [%o0 + 80]
+ st %i4, [%o0 + 84]
+ st %i5, [%o0 + 88]
+ st %i6, [%o0 + 92]
+ st %i7, [%o0 + 96]
+ mov %y, %o2 ! fetch %y, whatever it is
+ st %o2, [%o0 + 100] ! and save it
+ jmp %o7+8 ! return
+ add %g0, %g0, %o0 ! return 0
+
+ !
+ ! Restore an environment from a heap allocated continuation.
+ !
+ .global _sc_longjmp
+ _sc_longjmp:
+ ta 3 ! flush register windows
+ ld [%o0 + 0], %o6 ! restore stack pointer
+ ld [%o0 + 4], %o7 ! load continuation pointer
+ ld [%o0 + 8], %g1 ! restore global registers
+ ld [%o0 + 12], %g2
+ ld [%o0 + 16], %g3
+ ld [%o0 + 20], %g4
+ ld [%o0 + 24], %g5
+ ld [%o0 + 28], %g6
+ ld [%o0 + 32], %g7
+ ld [%o0 + 36], %l0 ! restore local frame from stack
+ ld [%o0 + 40], %l1
+ ld [%o0 + 44], %l2
+ ld [%o0 + 48], %l3
+ ld [%o0 + 52], %l4
+ ld [%o0 + 56], %l5
+ ld [%o0 + 60], %l6
+ ld [%o0 + 64], %l7
+ ld [%o0 + 68], %i0
+ ld [%o0 + 72], %i1
+ ld [%o0 + 76], %i2
+ ld [%o0 + 80], %i3
+ ld [%o0 + 84], %i4
+ ld [%o0 + 88], %i5
+ ld [%o0 + 92], %i6
+ ld [%o0 + 96], %i7
+ ld [%o0 + 100], %o2 ! restore %y, whatever it is
+ mov %o2, %y
+ jmp %o7+8 ! return
+ add %o1, %g0, %o0 ! return arg
+
*** /dev/null Fri Nov 9 17:27:21 1990
--- scrt/sun3.s Mon Nov 5 11:42:58 1990
***************
*** 0 ****
--- 1,69 ----
+ |
+ | SCHEME->C
+ |
+ | Sun3 assembly code.
+ |
+
+ |
+ | Copyright 1989 Digital Equipment Corporation
+ | All Rights Reserved
+ |
+ | Permission to use, copy, and modify this software and its documentation is
+ | hereby granted only under the following terms and conditions. Both the
+ | above copyright notice and this permission notice must appear in all copies
+ | of the software, derivative works or modified versions, and any portions
+ | thereof, and both notices must appear in supporting documentation.
+ |
+ | Users of this software agree to the terms and conditions set forth herein,
+ | and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
+ | right and license under any changes, enhancements or extensions made to the
+ | core functions of the software, including but not limited to those affording
+ | compatibility with other hardware or software environments, but excluding
+ | applications which incorporate this software. Users further agree to use
+ | their best efforts to return to Digital any such changes, enhancements or
+ | extensions that they make and inform Digital of noteworthy uses of this
+ | software. Correspondence should be provided to Digital at:
+ |
+ | Director of Licensing
+ | Western Research Laboratory
+ | Digital Equipment Corporation
+ | 100 Hamilton Avenue
+ | Palo Alto, California 94301
+ |
+ | This software may be distributed (but not offered for sale or transferred
+ | for compensation) to third parties, provided such third parties agree to
+ | abide by the terms and conditions of this notice.
+ |
+ | THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
+ | WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
+ | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
+ | CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
+ | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
+ | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
+ | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+ | SOFTWARE.
+ |
+
+ |
+ | sc_a2to5d2to7
+ |
+ | sc_a2to5d2to7( a )
+ | will return the contents of A2, ..., A5, D2, ..., D7 starting at address 'a'.
+ |
+ |
+ .text
+ .globl _sc_a2to5d2to7
+ .even
+ _sc_a2to5d2to7:
+ movl sp@(4),a0
+ movl a2,a0@(0)
+ movl a3,a0@(4)
+ movl a4,a0@(8)
+ movl a5,a0@(12)
+ movl d2,a0@(16)
+ movl d3,a0@(20)
+ movl d4,a0@(24)
+ movl d5,a0@(28)
+ movl d6,a0@(32)
+ movl d7,a0@(36)
+ rts