even more 0.4.0 hacks
This commit is contained in:
bdc
parent
965a0da2f1
commit
12874c0edd
|
|
@ -20,7 +20,7 @@ LDFLAGS_AIX= @LDFLAGS_AIX@
|
||||||
|
|
||||||
RM = rm -f
|
RM = rm -f
|
||||||
|
|
||||||
AR = ar cq
|
AR = @AR@
|
||||||
RANLIB = ranlib
|
RANLIB = ranlib
|
||||||
|
|
||||||
SHELL = /bin/sh
|
SHELL = /bin/sh
|
||||||
|
|
|
||||||
|
|
@ -779,6 +779,9 @@ else
|
||||||
ENDIAN=big
|
ENDIAN=big
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
AR=${AR-"ar cq"}
|
||||||
|
TMPDIR=${TMPDIR-"/usr/tmp"}
|
||||||
|
|
||||||
case "$host" in
|
case "$host" in
|
||||||
|
|
||||||
## CX/UX
|
## CX/UX
|
||||||
|
|
@ -936,7 +939,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lm $LIBS"
|
LIBS="-lm $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 940 "configure"
|
#line 943 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -975,7 +978,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lgen $LIBS"
|
LIBS="-lgen $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 979 "configure"
|
#line 982 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1014,7 +1017,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lnsl $LIBS"
|
LIBS="-lnsl $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1018 "configure"
|
#line 1021 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1053,7 +1056,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lsocket $LIBS"
|
LIBS="-lsocket $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1057 "configure"
|
#line 1060 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1092,7 +1095,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lelf $LIBS"
|
LIBS="-lelf $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1096 "configure"
|
#line 1099 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1131,7 +1134,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-lld $LIBS"
|
LIBS="-lld $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1135 "configure"
|
#line 1138 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1170,7 +1173,7 @@ else
|
||||||
ac_save_LIBS="$LIBS"
|
ac_save_LIBS="$LIBS"
|
||||||
LIBS="-ldl $LIBS"
|
LIBS="-ldl $LIBS"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1174 "configure"
|
#line 1177 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
|
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1208,7 +1211,7 @@ if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then
|
||||||
echo $ac_n "(cached) $ac_c" 1>&6
|
echo $ac_n "(cached) $ac_c" 1>&6
|
||||||
else
|
else
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1212 "configure"
|
#line 1215 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <sys/types.h>
|
#include <sys/types.h>
|
||||||
#include <signal.h>
|
#include <signal.h>
|
||||||
|
|
@ -1255,7 +1258,7 @@ else
|
||||||
# On the NeXT, cc -E runs the code through the compiler's parser,
|
# On the NeXT, cc -E runs the code through the compiler's parser,
|
||||||
# not just through cpp.
|
# not just through cpp.
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1259 "configure"
|
#line 1262 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <assert.h>
|
#include <assert.h>
|
||||||
Syntax Error
|
Syntax Error
|
||||||
|
|
@ -1269,7 +1272,7 @@ else
|
||||||
rm -rf conftest*
|
rm -rf conftest*
|
||||||
CPP="${CC-cc} -E -traditional-cpp"
|
CPP="${CC-cc} -E -traditional-cpp"
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1273 "configure"
|
#line 1276 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <assert.h>
|
#include <assert.h>
|
||||||
Syntax Error
|
Syntax Error
|
||||||
|
|
@ -1302,7 +1305,7 @@ if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
|
||||||
echo $ac_n "(cached) $ac_c" 1>&6
|
echo $ac_n "(cached) $ac_c" 1>&6
|
||||||
else
|
else
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1306 "configure"
|
#line 1309 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <$ac_hdr>
|
#include <$ac_hdr>
|
||||||
EOF
|
EOF
|
||||||
|
|
@ -1337,7 +1340,7 @@ if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
|
||||||
echo $ac_n "(cached) $ac_c" 1>&6
|
echo $ac_n "(cached) $ac_c" 1>&6
|
||||||
else
|
else
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1341 "configure"
|
#line 1344 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
/* System header to define __stub macros and hopefully few prototypes,
|
/* System header to define __stub macros and hopefully few prototypes,
|
||||||
which can conflict with char $ac_func(); below. */
|
which can conflict with char $ac_func(); below. */
|
||||||
|
|
@ -1388,7 +1391,7 @@ if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
|
||||||
echo $ac_n "(cached) $ac_c" 1>&6
|
echo $ac_n "(cached) $ac_c" 1>&6
|
||||||
else
|
else
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1392 "configure"
|
#line 1395 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
/* System header to define __stub macros and hopefully few prototypes,
|
/* System header to define __stub macros and hopefully few prototypes,
|
||||||
which can conflict with char $ac_func(); below. */
|
which can conflict with char $ac_func(); below. */
|
||||||
|
|
@ -1510,7 +1513,7 @@ EOF
|
||||||
else
|
else
|
||||||
|
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1514 "configure"
|
#line 1517 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <nlist.h>
|
#include <nlist.h>
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1545,7 +1548,7 @@ EOF
|
||||||
else
|
else
|
||||||
|
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1549 "configure"
|
#line 1552 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1580,7 +1583,7 @@ EOF
|
||||||
else
|
else
|
||||||
|
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1584 "configure"
|
#line 1587 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <time.h>
|
#include <time.h>
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1614,7 +1617,7 @@ EOF
|
||||||
else
|
else
|
||||||
|
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1618 "configure"
|
#line 1621 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <time.h>
|
#include <time.h>
|
||||||
int main() { return 0; }
|
int main() { return 0; }
|
||||||
|
|
@ -1649,7 +1652,7 @@ EOF
|
||||||
else
|
else
|
||||||
|
|
||||||
cat > conftest.$ac_ext <<EOF
|
cat > conftest.$ac_ext <<EOF
|
||||||
#line 1653 "configure"
|
#line 1656 "configure"
|
||||||
#include "confdefs.h"
|
#include "confdefs.h"
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
#include <unistd.h>
|
#include <unistd.h>
|
||||||
|
|
@ -1687,6 +1690,9 @@ CFLAGS1=${CFLAGS}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
trap '' 1 2 15
|
trap '' 1 2 15
|
||||||
cat > confcache <<\EOF
|
cat > confcache <<\EOF
|
||||||
# This file is a shell script that caches the results of configure
|
# This file is a shell script that caches the results of configure
|
||||||
|
|
@ -1774,7 +1780,7 @@ done
|
||||||
ac_given_srcdir=$srcdir
|
ac_given_srcdir=$srcdir
|
||||||
ac_given_INSTALL="$INSTALL"
|
ac_given_INSTALL="$INSTALL"
|
||||||
|
|
||||||
trap 'rm -fr `echo "Makefile scsh/regexp/Makefile scsh/network.scm sysdep.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
|
trap 'rm -fr `echo "Makefile scsh/regexp/Makefile scsh/endian.scm scsh/static.scm sysdep.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
|
||||||
|
|
||||||
# Protect against being on the right side of a sed subst in config.status.
|
# Protect against being on the right side of a sed subst in config.status.
|
||||||
sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g;
|
sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g;
|
||||||
|
|
@ -1800,15 +1806,17 @@ s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
|
||||||
s%@INSTALL_DATA@%$INSTALL_DATA%g
|
s%@INSTALL_DATA@%$INSTALL_DATA%g
|
||||||
s%@CPP@%$CPP%g
|
s%@CPP@%$CPP%g
|
||||||
s%@AIX_P@%$AIX_P%g
|
s%@AIX_P@%$AIX_P%g
|
||||||
|
s%@AR@%$AR%g
|
||||||
s%@CFLAGS1@%$CFLAGS1%g
|
s%@CFLAGS1@%$CFLAGS1%g
|
||||||
s%@ENDIAN@%$ENDIAN%g
|
s%@ENDIAN@%$ENDIAN%g
|
||||||
s%@LDFLAGS_AIX@%$LDFLAGS_AIX%g
|
s%@LDFLAGS_AIX@%$LDFLAGS_AIX%g
|
||||||
|
s%@TMPDIR@%$TMPDIR%g
|
||||||
|
|
||||||
CEOF
|
CEOF
|
||||||
EOF
|
EOF
|
||||||
cat >> $CONFIG_STATUS <<EOF
|
cat >> $CONFIG_STATUS <<EOF
|
||||||
|
|
||||||
CONFIG_FILES=\${CONFIG_FILES-"Makefile scsh/regexp/Makefile scsh/network.scm"}
|
CONFIG_FILES=\${CONFIG_FILES-"Makefile scsh/regexp/Makefile scsh/endian.scm scsh/static.scm"}
|
||||||
EOF
|
EOF
|
||||||
cat >> $CONFIG_STATUS <<\EOF
|
cat >> $CONFIG_STATUS <<\EOF
|
||||||
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
|
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
|
||||||
|
|
@ -1968,3 +1976,4 @@ chmod +x $CONFIG_STATUS
|
||||||
rm -fr confdefs* $ac_clean_files
|
rm -fr confdefs* $ac_clean_files
|
||||||
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
|
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
|
||||||
|
|
||||||
|
chmod +x scsh/static.scm
|
||||||
|
|
|
||||||
|
|
@ -199,6 +199,9 @@ else
|
||||||
ENDIAN=big
|
ENDIAN=big
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
AR=${AR-"ar cq"}
|
||||||
|
TMPDIR=${TMPDIR-"/usr/tmp"}
|
||||||
|
|
||||||
case "$host" in
|
case "$host" in
|
||||||
|
|
||||||
## CX/UX
|
## CX/UX
|
||||||
|
|
@ -319,10 +322,14 @@ SCSH_CONST_SYS_ERRLIST
|
||||||
CFLAGS1=${CFLAGS}
|
CFLAGS1=${CFLAGS}
|
||||||
|
|
||||||
AC_SUBST(AIX_P)
|
AC_SUBST(AIX_P)
|
||||||
|
AC_SUBST(AR)
|
||||||
|
AC_SUBST(CC)
|
||||||
AC_SUBST(CFLAGS)
|
AC_SUBST(CFLAGS)
|
||||||
AC_SUBST(CFLAGS1)
|
AC_SUBST(CFLAGS1)
|
||||||
AC_SUBST(ENDIAN)
|
AC_SUBST(ENDIAN)
|
||||||
AC_SUBST(LDFLAGS)
|
AC_SUBST(LDFLAGS)
|
||||||
AC_SUBST(LDFLAGS_AIX)
|
AC_SUBST(LDFLAGS_AIX)
|
||||||
|
AC_SUBST(TMPDIR)
|
||||||
|
|
||||||
AC_OUTPUT(Makefile scsh/regexp/Makefile scsh/endian.scm)
|
AC_OUTPUT(Makefile scsh/regexp/Makefile scsh/endian.scm scsh/static.scm)
|
||||||
|
chmod +x scsh/static.scm
|
||||||
|
|
|
||||||
|
|
@ -381,6 +381,24 @@ scheme_value df_scheme_proto_name2proto_info(long nargs, scheme_value *args)
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
scheme_value df_veclen(long nargs, scheme_value *args)
|
||||||
|
{
|
||||||
|
extern scheme_value veclen(const long * );
|
||||||
|
scheme_value ret1;
|
||||||
|
scheme_value r1;
|
||||||
|
|
||||||
|
cig_check_nargs(1, nargs, "veclen");
|
||||||
|
r1 = veclen((const long * )AlienVal(args[0]));
|
||||||
|
ret1 = r1;
|
||||||
|
return ret1;
|
||||||
|
}
|
||||||
|
|
||||||
|
scheme_value df_set_longvec_carriers(long nargs, scheme_value *args)
|
||||||
|
{
|
||||||
|
extern void set_longvec_carriers(scheme_value , long const * const * );
|
||||||
|
|
||||||
|
cig_check_nargs(2, nargs, "set_longvec_carriers");
|
||||||
|
set_longvec_carriers(args[1], (long const * const * )AlienVal(args[0]));
|
||||||
|
return SCHFALSE;
|
||||||
|
}
|
||||||
|
|
||||||
Error: end of file inside list -- unbalanced parentheses
|
|
||||||
#{Input-port}
|
|
||||||
|
|
|
||||||
|
|
@ -25,6 +25,21 @@
|
||||||
defrec-package
|
defrec-package
|
||||||
scsh)
|
scsh)
|
||||||
(begin
|
(begin
|
||||||
|
|
||||||
|
(define (scsh-static-linker argl)
|
||||||
|
(if (not (= (length argl) 3))
|
||||||
|
(error "usage: ~a input-image-file output-archive-file" (car argl))
|
||||||
|
(let ((tempdir (or (getenv "TMPDIR")
|
||||||
|
"/usr/tmp"))
|
||||||
|
(cc-command (or (getenv "CC")
|
||||||
|
"gcc -g -O"))
|
||||||
|
(ar-command (or (getenv "AR")
|
||||||
|
"ar cq"))
|
||||||
|
(infile (cadr argl))
|
||||||
|
(outfile (caddr argl)))
|
||||||
|
(scsh-do-it infile tempdir outfile cc-command ar-command)
|
||||||
|
(exit 0))))
|
||||||
|
|
||||||
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
(define-record heap
|
(define-record heap
|
||||||
(length 0)
|
(length 0)
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,675 @@
|
||||||
|
#!/usr/local/bin/scsh \
|
||||||
|
-lm /usr/local/lib/scsh/vm/ps-interface.scm -lm /usr/local/lib/scsh/vm/interfaces.scm -lm /usr/local/lib/scsh/vm/package-defs.scm -lm /usr/local/lib/scsh/vm/s48-package-defs.scm -m heap -l /usr/local/lib/scsh/scsh/static-heap.scm -dm -m scsh-static-heap -e scsh-static-linker -s
|
||||||
|
!#
|
||||||
|
;;; Package for Static heaps for the Scheme Shell
|
||||||
|
;;; Copyright (c) 1995 by Brian D. Carlstrom.
|
||||||
|
|
||||||
|
;;; based on Scheme48 implementation.
|
||||||
|
;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
|
||||||
|
|
||||||
|
(define-structure heap-extra (export newspace-begin
|
||||||
|
heap-pointer
|
||||||
|
header-a-units
|
||||||
|
d-vector?
|
||||||
|
stob-type)
|
||||||
|
(open scheme heap))
|
||||||
|
|
||||||
|
(define-structure scsh-static-heap (export scsh-static-linker)
|
||||||
|
(open scheme heap memory data stob struct
|
||||||
|
heap-extra
|
||||||
|
vm-architecture
|
||||||
|
formats
|
||||||
|
enumerated
|
||||||
|
signals
|
||||||
|
tables
|
||||||
|
defrec-package
|
||||||
|
scsh)
|
||||||
|
(begin
|
||||||
|
|
||||||
|
(define (scsh-static-linker argl)
|
||||||
|
(if (not (= (length argl) 3))
|
||||||
|
(error "usage: ~a input-image-file output-archive-file" (car argl))
|
||||||
|
(let ((tempdir (or (getenv "TMPDIR")
|
||||||
|
"@TMPDIR@"))
|
||||||
|
(cc-command (or (getenv "CC")
|
||||||
|
"@CC@ @CFLAGS@"))
|
||||||
|
(ar-command (or (getenv "AR")
|
||||||
|
"@AR@"))
|
||||||
|
(infile (cadr argl))
|
||||||
|
(outfile (caddr argl)))
|
||||||
|
(scsh-do-it infile tempdir outfile cc-command ar-command)
|
||||||
|
(exit 0))))
|
||||||
|
|
||||||
|
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
(define-record heap
|
||||||
|
(length 0)
|
||||||
|
(objects '())
|
||||||
|
)
|
||||||
|
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
(define (scsh-do-it infile tempdir outfile cc-command ar-command)
|
||||||
|
(let* ((temp-dir (format #f "~a/scsh~s" tempdir (pid)))
|
||||||
|
(prefix (string-append temp-dir "/static"))
|
||||||
|
(start (read-heap-image infile)))
|
||||||
|
(receive (pure impure reloc externs)
|
||||||
|
(create-heaps-and-tables)
|
||||||
|
(if (file-exists? temp-dir)
|
||||||
|
(if (file-directory? temp-dir)
|
||||||
|
(with-cwd temp-dir
|
||||||
|
(map delete-file (directory-files temp-dir #t)))
|
||||||
|
(delete-file temp-dir)))
|
||||||
|
(create-directory temp-dir #o755 #t)
|
||||||
|
(with-cwd temp-dir
|
||||||
|
(write-c-header-file pure impure externs infile outfile prefix)
|
||||||
|
(write-c-image pure impure reloc externs prefix)
|
||||||
|
(write-main-c-file start reloc prefix)
|
||||||
|
(compile-c-files cc-command prefix))
|
||||||
|
(archive-files ar-command outfile prefix)
|
||||||
|
)))
|
||||||
|
|
||||||
|
|
||||||
|
(define debug #f)
|
||||||
|
|
||||||
|
(define (vm-string->string x)
|
||||||
|
(cond ((vm-string? x)
|
||||||
|
(let ((len (vm-string-length x)))
|
||||||
|
(let loop ((i 0)
|
||||||
|
(l '()))
|
||||||
|
(cond ((= i len)
|
||||||
|
(list->string (reverse l)))
|
||||||
|
(else
|
||||||
|
(loop (+ i 1) (cons (vm-string-ref x i) l)))))))
|
||||||
|
(else
|
||||||
|
(message x " is not a vm-string"))))
|
||||||
|
|
||||||
|
(define (read-heap-image infile)
|
||||||
|
(let ((bytes (file-info:size (file-info infile))))
|
||||||
|
(init (inexact->exact (floor (* 1.1 bytes))) infile)))
|
||||||
|
; XXX need little extra space for find-all-xs
|
||||||
|
|
||||||
|
(define (create-heaps-and-tables)
|
||||||
|
(let* ((n (nchunks))
|
||||||
|
( pure (make-vector n))
|
||||||
|
(impure (make-vector n))
|
||||||
|
(reloc (make-vector n))
|
||||||
|
(externs (make-table )))
|
||||||
|
;; initialize to blanks
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond ((not (= i n))
|
||||||
|
(vector-set! pure i (make-heap ))
|
||||||
|
(vector-set! impure i (make-heap ))
|
||||||
|
(vector-set! reloc i (make-table))
|
||||||
|
(loop (+ i 1)))))
|
||||||
|
(scsh-for-each-stored-object
|
||||||
|
(lambda (chunk)
|
||||||
|
(format #t "Reading chunk number ~s" chunk))
|
||||||
|
(lambda (chunk x len)
|
||||||
|
(if debug
|
||||||
|
(write x))
|
||||||
|
(let* ((mutable (mutable? x))
|
||||||
|
(heap (vector-ref (if mutable impure pure) chunk)))
|
||||||
|
(table-set! (vector-ref reloc chunk) x (heap:length heap))
|
||||||
|
(set-heap:objects heap (cons x (heap:objects heap)))
|
||||||
|
(set-heap:length heap (+ len (heap:length heap)))
|
||||||
|
(cond (debug
|
||||||
|
(display (if mutable " mutable " " immutable "))
|
||||||
|
(cond ((d-vector? x) (display " d-vector"))
|
||||||
|
((vm-string? x) (display "vm-string"))
|
||||||
|
(else (display " b-vector")))
|
||||||
|
(let ((m (heap:length (vector-ref impure chunk)))
|
||||||
|
(i (heap:length (vector-ref pure chunk))))
|
||||||
|
(message " m" m "+i" i "=" (+ m i))))))
|
||||||
|
(if (= (header-type (stob-header x)) (enum stob external))
|
||||||
|
(table-set! externs
|
||||||
|
(external-value x)
|
||||||
|
(vm-string->string (external-name x))))
|
||||||
|
)
|
||||||
|
(lambda (chunk)
|
||||||
|
(newline)))
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond ((not (= i n))
|
||||||
|
(let ((p (vector-ref pure i))
|
||||||
|
(i (vector-ref impure i)))
|
||||||
|
(set-heap:objects p (reverse (heap:objects p)))
|
||||||
|
(set-heap:objects i (reverse (heap:objects i))))
|
||||||
|
(loop (+ i 1)))))
|
||||||
|
(values pure impure reloc externs)))
|
||||||
|
|
||||||
|
(define (write-c-header-file pure impure externs infile outfile prefix)
|
||||||
|
(message "Writing header file")
|
||||||
|
(call-with-output-file (string-append prefix ".h")
|
||||||
|
(lambda (port)
|
||||||
|
(format port "/* Static Heap File Automatically Generated~%")
|
||||||
|
(format port " * by scsh/static.scm~%")
|
||||||
|
(format port " * from ~a~%" infile)
|
||||||
|
(format port " * to ~a~%" outfile)
|
||||||
|
(format port " */~%")
|
||||||
|
(let ((n (nchunks)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "extern const long p~s[~s];~%" i
|
||||||
|
(quotient (heap:length (vector-ref pure i)) 4)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "extern long i~s[~s];~%" i
|
||||||
|
(quotient (heap:length (vector-ref impure i)) 4))))
|
||||||
|
(table-walk
|
||||||
|
(lambda (address name)
|
||||||
|
(format port "const extern ~a();~%" name))
|
||||||
|
externs)
|
||||||
|
)))
|
||||||
|
|
||||||
|
(define (d-vector-for-each proc d-vector)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((>= i (d-vector-length d-vector)))
|
||||||
|
(proc (d-vector-ref d-vector i))))
|
||||||
|
|
||||||
|
(define (write-c-image pure impure reloc externs prefix)
|
||||||
|
(message "Writing pure c files")
|
||||||
|
(scsh-write-c-image pure "p" "const " reloc externs prefix)
|
||||||
|
(message "Writing impure c files")
|
||||||
|
(scsh-write-c-image impure "i" "" reloc externs prefix))
|
||||||
|
|
||||||
|
(define (scsh-write-c-image heap name const reloc externs prefix)
|
||||||
|
(let ((n (nchunks)))
|
||||||
|
(let chunk-loop ((c 0))
|
||||||
|
(cond ((not (= c n))
|
||||||
|
(format #t "Writing ~a-~a~s.c~%" prefix name c)
|
||||||
|
(call-with-output-file
|
||||||
|
(format #f "~a-~a~s.c" prefix name c)
|
||||||
|
(lambda (port)
|
||||||
|
(format port "#include \"~a.h\"~%" prefix)
|
||||||
|
(format port "~a long ~a~s[]={~%" const name c)
|
||||||
|
(let ((heap (vector-ref heap c)))
|
||||||
|
(let heap-loop ((l (heap:objects heap)))
|
||||||
|
(cond ((not (null? l))
|
||||||
|
(scsh-emit-initializer (car l) reloc externs port)
|
||||||
|
(heap-loop (cdr l))))))
|
||||||
|
(display "};" port)
|
||||||
|
(newline port)))
|
||||||
|
(chunk-loop (+ 1 c)))))))
|
||||||
|
|
||||||
|
(define (write-main-c-file start reloc prefix)
|
||||||
|
(let ((n (nchunks)))
|
||||||
|
(call-with-output-file (string-append prefix ".c")
|
||||||
|
(lambda (port)
|
||||||
|
(format port "#include \"~a.h\"~%" prefix)
|
||||||
|
(format port "const long p_count = ~s;~%" n)
|
||||||
|
(format port "const long i_count = ~s;~%" n)
|
||||||
|
|
||||||
|
(format port "const long * const p_areas[~s] = {" n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "(const long *) &p~s, " i))
|
||||||
|
(format port "};~%")
|
||||||
|
|
||||||
|
(format port "long * const i_areas[~s] = {" n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "(long *) &i~s, " i))
|
||||||
|
(format port "};~%")
|
||||||
|
|
||||||
|
(format port "const long p_sizes[~s] = {" n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "sizeof(p~s), " i))
|
||||||
|
(format port "};~%")
|
||||||
|
|
||||||
|
(format port "const long i_sizes[~s] = {" n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "sizeof(i~s), " i))
|
||||||
|
(format port "};~%")
|
||||||
|
|
||||||
|
(display "const long entry = " port)
|
||||||
|
(scsh-emit-descriptor start reloc port)
|
||||||
|
(write-char #\; port)
|
||||||
|
(newline port)))))
|
||||||
|
|
||||||
|
(define (compile-c-files cc-command prefix)
|
||||||
|
(let ((n (nchunks))
|
||||||
|
(cc (line->list cc-command)))
|
||||||
|
(message "Compiling main C file")
|
||||||
|
(run (,@(append cc (list (format #f "~a.c" prefix)))))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(message "Compiling C file for pure chunk " i)
|
||||||
|
(run (,@(append cc
|
||||||
|
(list (format #f "~a-p~s.c" prefix i)))))
|
||||||
|
(message "Compiling C file for impure chunk " i)
|
||||||
|
(run (,@(append cc
|
||||||
|
(list (format #f "~a-i~s.c" prefix i))))))))
|
||||||
|
|
||||||
|
(define (archive-files ar-command outfile prefix)
|
||||||
|
(let ((n (nchunks))
|
||||||
|
(ar (line->list ar-command)))
|
||||||
|
(message "Archiving object files")
|
||||||
|
(run (,@(append
|
||||||
|
ar
|
||||||
|
(cons
|
||||||
|
outfile
|
||||||
|
(let loop ((i 0)
|
||||||
|
(l '()))
|
||||||
|
(cond ((not (= i n))
|
||||||
|
(loop (+ i 1)
|
||||||
|
(cons
|
||||||
|
(format #f "~a-i~s.o" prefix i)
|
||||||
|
(cons
|
||||||
|
(format #f "~a-p~s.o" prefix i)
|
||||||
|
l))))
|
||||||
|
(else
|
||||||
|
(reverse
|
||||||
|
(cons
|
||||||
|
(string-append prefix ".o")
|
||||||
|
l)))))))))))
|
||||||
|
|
||||||
|
(define (scsh-emit-initializer x reloc externs port)
|
||||||
|
(write-hex port (stob-header x))
|
||||||
|
(cond ((d-vector? x)
|
||||||
|
(scsh-emit-d-vector-initializer x reloc port))
|
||||||
|
((vm-string? x)
|
||||||
|
(scsh-emit-vm-string-initializer x port))
|
||||||
|
(else
|
||||||
|
(scsh-emit-b-vector-initializer x reloc externs port)))
|
||||||
|
(if *comments?*
|
||||||
|
(begin (display " /* " port)
|
||||||
|
(writex x port)
|
||||||
|
(display " */" port)))
|
||||||
|
(newline port))
|
||||||
|
|
||||||
|
|
||||||
|
(define (scsh-emit-d-vector-initializer x reloc port)
|
||||||
|
(let ((len (d-vector-length x)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i len))
|
||||||
|
(scsh-emit-descriptor (d-vector-ref x i) reloc port)
|
||||||
|
(write-char #\, port))))
|
||||||
|
|
||||||
|
(define (scsh-emit-vm-string-initializer x port)
|
||||||
|
(let* ((len (vm-string-length x)) ; end is jawilson style hack
|
||||||
|
(end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
|
||||||
|
(do ((i 0 (+ i 4)))
|
||||||
|
((= i end)
|
||||||
|
(case (- len end)
|
||||||
|
((0)
|
||||||
|
(write-hex port 0))
|
||||||
|
((1)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32 (arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x i)) 24))))
|
||||||
|
((2)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x i)) 24)
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x (+ i 1))) 16)))))
|
||||||
|
((3)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32
|
||||||
|
(bitwise-ior
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x i)) 24)
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x (+ i 1))) 16))
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x (+ i 2))) 8)))))))
|
||||||
|
(write-hex port
|
||||||
|
(net-to-host-32 (bitwise-ior
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x i)) 24)
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x (+ i 1))) 16))
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift
|
||||||
|
(char->ascii (vm-string-ref x (+ i 2))) 8)
|
||||||
|
(char->ascii (vm-string-ref x (+ i 3))))))
|
||||||
|
))))
|
||||||
|
|
||||||
|
(define (scsh-emit-b-vector-initializer x reloc externs port)
|
||||||
|
(cond ((and (code-vector? x)
|
||||||
|
(table-ref externs x)) =>
|
||||||
|
(lambda (name)
|
||||||
|
(format port "(long) *~a," name)))
|
||||||
|
(else
|
||||||
|
(let* ((len (b-vector-length x)) ;end is jawilson style hack
|
||||||
|
(end (- (cells->bytes (bytes->cells (+ len 1))) 4)))
|
||||||
|
(do ((i 0 (+ i 4)))
|
||||||
|
((= i end)
|
||||||
|
(case (- len end)
|
||||||
|
((1)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32 (arithmetic-shift (b-vector-ref x i) 24))))
|
||||||
|
((2)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift (b-vector-ref x i) 24)
|
||||||
|
(arithmetic-shift (b-vector-ref x (+ i 1)) 16)))))
|
||||||
|
((3)
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32
|
||||||
|
(bitwise-ior
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift (b-vector-ref x i) 24)
|
||||||
|
(arithmetic-shift (b-vector-ref x (+ i 1)) 16))
|
||||||
|
(arithmetic-shift (b-vector-ref x (+ i 2)) 8)))
|
||||||
|
))))
|
||||||
|
(write-hex
|
||||||
|
port
|
||||||
|
(net-to-host-32 (bitwise-ior
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift (b-vector-ref x i) 24)
|
||||||
|
(arithmetic-shift (b-vector-ref x (+ i 1)) 16))
|
||||||
|
(bitwise-ior
|
||||||
|
(arithmetic-shift (b-vector-ref x (+ i 2)) 8)
|
||||||
|
(b-vector-ref x (+ i 3))))))))
|
||||||
|
)))
|
||||||
|
|
||||||
|
(define (scsh-emit-descriptor x reloc port)
|
||||||
|
(if (stob? x)
|
||||||
|
(let ((n (chunk-number x)))
|
||||||
|
(display "(long)(&" port)
|
||||||
|
(if (immutable? x)
|
||||||
|
(display "p" port)
|
||||||
|
(display "i" port))
|
||||||
|
(display n port)
|
||||||
|
(display "[" port)
|
||||||
|
(display (quotient (table-ref (vector-ref reloc n) x) 4) port)
|
||||||
|
(display "])+7" port))
|
||||||
|
(format port
|
||||||
|
(if (negative? x) "-0x~a" "0x~a")
|
||||||
|
(number->string (abs x) 16))))
|
||||||
|
|
||||||
|
(define (scsh-for-each-stored-object chunk-start proc chunk-end)
|
||||||
|
(let ((limit (heap-pointer)))
|
||||||
|
(let chunk-loop ((addr (newspace-begin))
|
||||||
|
(i 0)
|
||||||
|
(chunk (+ (newspace-begin) *chunk-size*)))
|
||||||
|
(if (addr< addr limit)
|
||||||
|
(begin (chunk-start i)
|
||||||
|
(let loop ((addr addr))
|
||||||
|
(if (and (addr< addr limit)
|
||||||
|
(addr< addr chunk))
|
||||||
|
(let* ((d (fetch addr))
|
||||||
|
(len (addr1+ (header-a-units d))))
|
||||||
|
(if (not (header? d))
|
||||||
|
(warn "heap is in an inconsistent state" d))
|
||||||
|
(proc i (address->stob-descriptor (addr1+ addr)) len)
|
||||||
|
(loop (addr+ addr len)))
|
||||||
|
(begin (chunk-end i)
|
||||||
|
(chunk-loop addr
|
||||||
|
(+ i 1)
|
||||||
|
(+ chunk *chunk-size*))))))))))
|
||||||
|
|
||||||
|
(define (write-hex port x)
|
||||||
|
(format port
|
||||||
|
(if (negative? x) "-0x~a," "0x~a,")
|
||||||
|
(number->string (abs x) 16)))
|
||||||
|
|
||||||
|
;; takes a string and break it into a list at whitespace
|
||||||
|
;; rewrite using scsh stuff?
|
||||||
|
(define (line->list line)
|
||||||
|
(let ((len (string-length line)))
|
||||||
|
(let loop ((start 0)
|
||||||
|
(end 0)
|
||||||
|
(l '()))
|
||||||
|
(cond ((>= end len)
|
||||||
|
(if (= start end)
|
||||||
|
l
|
||||||
|
(append l (list (substring line start end)))))
|
||||||
|
((and (= start end)
|
||||||
|
(or (char=? (string-ref line start) (ascii->char 32))
|
||||||
|
(char=? (string-ref line start) (ascii->char 9))))
|
||||||
|
(loop (+ 1 start)
|
||||||
|
(+ 1 end)
|
||||||
|
l))
|
||||||
|
((or (char=? (string-ref line end) (ascii->char 32))
|
||||||
|
(char=? (string-ref line end) (ascii->char 9)))
|
||||||
|
(loop (+ 1 end)
|
||||||
|
(+ 1 end)
|
||||||
|
(append l (list (substring line start end)))))
|
||||||
|
((< end len)
|
||||||
|
(loop start
|
||||||
|
(+ 1 end)
|
||||||
|
l))
|
||||||
|
(else (error "unexpected case in line->list"))))))
|
||||||
|
|
||||||
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
;;; Debugging
|
||||||
|
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
|
||||||
|
(define (bin n)
|
||||||
|
(number->string n 2))
|
||||||
|
|
||||||
|
(define (oct n)
|
||||||
|
(number->string n 8))
|
||||||
|
|
||||||
|
(define (dec n)
|
||||||
|
(number->string n 10))
|
||||||
|
|
||||||
|
(define (hex n)
|
||||||
|
(number->string n 16))
|
||||||
|
|
||||||
|
;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||||
|
|
||||||
|
; For example:
|
||||||
|
; (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
|
||||||
|
;
|
||||||
|
; The first argument to do-it should be somewhat larger than the size,
|
||||||
|
; in bytes, of the image file to be converted (which you can obtain with
|
||||||
|
; "ls -l").
|
||||||
|
;
|
||||||
|
; If the image contains 0-length stored objects, then the .c file will
|
||||||
|
; have to be compiled by gcc, since 0-length arrays aren't allowed in
|
||||||
|
; ANSI C. This wouldn't be difficult to work around.
|
||||||
|
|
||||||
|
(define *comments?* #f)
|
||||||
|
|
||||||
|
; 800,000 bytes => 200,000 words => at least 100,000 objects
|
||||||
|
; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
|
||||||
|
(define *chunk-size* 10000)
|
||||||
|
|
||||||
|
(define (do-it bytes infile outfile)
|
||||||
|
(let ((start (init bytes infile)))
|
||||||
|
(call-with-output-file outfile
|
||||||
|
(lambda (port)
|
||||||
|
(format port "#define D(x) (long)(&x)+7~%")
|
||||||
|
(format port "#define H unsigned long~%")
|
||||||
|
(emit-area-declarations "p" immutable? "const " port)
|
||||||
|
(emit-area-declarations "i" mutable? "" port)
|
||||||
|
(emit-area-initializers "p" immutable? "const " port)
|
||||||
|
(emit-area-initializers "i" mutable? "" port)
|
||||||
|
(display "const long entry = " port)
|
||||||
|
(emit-descriptor start port)
|
||||||
|
(write-char #\; port)
|
||||||
|
(newline port)))))
|
||||||
|
|
||||||
|
(define (init bytes infile)
|
||||||
|
(create-memory (quotient bytes 2) quiescent) ;Output of ls -l
|
||||||
|
(initialize-heap (memory-begin) (memory-size))
|
||||||
|
(let ((start (read-image infile 0)))
|
||||||
|
(message (nchunks)
|
||||||
|
" chunks")
|
||||||
|
start))
|
||||||
|
|
||||||
|
(define (nchunks) (+ (chunk-number (heap-pointer)) 1))
|
||||||
|
|
||||||
|
; emit struct declarations for areas
|
||||||
|
|
||||||
|
(define (emit-area-declarations name in-area? const port)
|
||||||
|
(for-each-stored-object
|
||||||
|
(lambda (chunk)
|
||||||
|
(message name chunk " declaration")
|
||||||
|
(display "struct " port) (display name port) (display chunk port)
|
||||||
|
(display " {" port) (newline port))
|
||||||
|
(lambda (x)
|
||||||
|
(if (in-area? x)
|
||||||
|
(emit-declaration x port)))
|
||||||
|
(lambda (chunk)
|
||||||
|
(display "};" port)
|
||||||
|
(newline port)
|
||||||
|
(display const port)
|
||||||
|
(display "extern struct " port) (display name port) (display chunk port)
|
||||||
|
(write-char #\space port) (display name port) (display chunk port)
|
||||||
|
(write-char #\; port) (newline port)
|
||||||
|
chunk)))
|
||||||
|
|
||||||
|
(define (emit-declaration x port)
|
||||||
|
(display " H x" port)
|
||||||
|
(writex x port)
|
||||||
|
(cond ((d-vector? x)
|
||||||
|
(display "; long d" port)
|
||||||
|
(writex x port)
|
||||||
|
(write-char #\[ port)
|
||||||
|
(write (d-vector-length x) port))
|
||||||
|
((vm-string? x)
|
||||||
|
(display "; char d" port)
|
||||||
|
(writex x port)
|
||||||
|
(write-char #\[ port)
|
||||||
|
;; Ensure alignment (thanks Ian)
|
||||||
|
(write (cells->bytes (bytes->cells (b-vector-length x)))
|
||||||
|
port))
|
||||||
|
(else
|
||||||
|
(display "; unsigned char d" port)
|
||||||
|
(writex x port)
|
||||||
|
(write-char #\[ port)
|
||||||
|
;; Ensure alignment
|
||||||
|
(write (cells->bytes (bytes->cells (b-vector-length x)))
|
||||||
|
port)))
|
||||||
|
(display "];" port)
|
||||||
|
(if *comments?*
|
||||||
|
(begin (display " /* " port)
|
||||||
|
(display (enumerand->name (stob-type x) stob) port)
|
||||||
|
(display " */" port)))
|
||||||
|
(newline port))
|
||||||
|
|
||||||
|
; Emit initializers for areas
|
||||||
|
|
||||||
|
(define (emit-area-initializers name in-area? const port)
|
||||||
|
(for-each-stored-object
|
||||||
|
(lambda (chunk)
|
||||||
|
(message name chunk " initializer")
|
||||||
|
|
||||||
|
(display const port)
|
||||||
|
(display "struct " port) (display name port) (write chunk port)
|
||||||
|
(write-char #\space port) (display name port) (write chunk port)
|
||||||
|
(display " =" port) (newline port)
|
||||||
|
|
||||||
|
(write-char #\{ port) (newline port))
|
||||||
|
(lambda (x)
|
||||||
|
(if (in-area? x)
|
||||||
|
(emit-initializer x port)))
|
||||||
|
(lambda (chunk)
|
||||||
|
(display "};" port) (newline port)))
|
||||||
|
|
||||||
|
(let ((n (nchunks)))
|
||||||
|
(format port "const long ~a_count = ~s;~%" name n)
|
||||||
|
(format port "~a long * const ~a_areas[~s] = {" const name n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "(~a long *)&~a~s, " const name i))
|
||||||
|
(format port "};~%const long ~a_sizes[~s] = {" name n)
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i n))
|
||||||
|
(format port "sizeof(~a~s), " name i))
|
||||||
|
(format port "};~%")))
|
||||||
|
|
||||||
|
|
||||||
|
(define (message . stuff)
|
||||||
|
(for-each display stuff) (newline))
|
||||||
|
|
||||||
|
(define (emit-initializer x port)
|
||||||
|
(display " " port)
|
||||||
|
(write (stob-header x) port)
|
||||||
|
(write-char #\, port)
|
||||||
|
(cond ((d-vector? x)
|
||||||
|
(emit-d-vector-initializer x port))
|
||||||
|
((vm-string? x)
|
||||||
|
(write-char #\" port)
|
||||||
|
(let ((len (vm-string-length x)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i len) (write-char #\" port))
|
||||||
|
(let ((c (vm-string-ref x i)))
|
||||||
|
(cond ((or (char=? c #\") (char=? c #\\))
|
||||||
|
(write-char #\\ port))
|
||||||
|
((char=? c #\newline)
|
||||||
|
(display "\\n\\" port)))
|
||||||
|
(write-char c port)))))
|
||||||
|
(else
|
||||||
|
(write-char #\{ port)
|
||||||
|
(let ((len (b-vector-length x)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i len) (write-char #\} port))
|
||||||
|
(write (b-vector-ref x i) port)
|
||||||
|
(write-char #\, port)))))
|
||||||
|
(write-char #\, port)
|
||||||
|
(if *comments?*
|
||||||
|
(begin (display " /* " port)
|
||||||
|
(writex x port)
|
||||||
|
(display " */" port)))
|
||||||
|
(newline port))
|
||||||
|
|
||||||
|
(define (emit-d-vector-initializer x port)
|
||||||
|
(write-char #\{ port)
|
||||||
|
(let ((len (d-vector-length x)))
|
||||||
|
(do ((i 0 (+ i 1)))
|
||||||
|
((= i len) (write-char #\} port))
|
||||||
|
(emit-descriptor (d-vector-ref x i) port)
|
||||||
|
(write-char #\, port))))
|
||||||
|
|
||||||
|
(define (emit-descriptor x port)
|
||||||
|
(if (stob? x)
|
||||||
|
(begin (if (immutable? x)
|
||||||
|
(display "D(p" port)
|
||||||
|
(display "D(i" port))
|
||||||
|
(display (chunk-number x) port)
|
||||||
|
(display ".x" port)
|
||||||
|
(writex x port)
|
||||||
|
(write-char #\) port))
|
||||||
|
(write x port)))
|
||||||
|
|
||||||
|
|
||||||
|
; Foo
|
||||||
|
|
||||||
|
(define (writex x port)
|
||||||
|
(write (quotient (- (- x (memory-begin)) 7) 4) port))
|
||||||
|
|
||||||
|
(define (chunk-number x)
|
||||||
|
(quotient (- (- x (memory-begin)) 7) *chunk-size*))
|
||||||
|
|
||||||
|
|
||||||
|
; Image traversal utility
|
||||||
|
|
||||||
|
(define (for-each-stored-object chunk-start proc chunk-end)
|
||||||
|
(let ((limit (heap-pointer)))
|
||||||
|
(let chunk-loop ((addr (newspace-begin))
|
||||||
|
(i 0)
|
||||||
|
(chunk (+ (newspace-begin) *chunk-size*)))
|
||||||
|
(if (addr< addr limit)
|
||||||
|
(begin (chunk-start i)
|
||||||
|
(let loop ((addr addr))
|
||||||
|
(if (and (addr< addr limit)
|
||||||
|
(addr< addr chunk))
|
||||||
|
(let ((d (fetch addr)))
|
||||||
|
(if (not (header? d))
|
||||||
|
(warn "heap is in an inconsistent state" d))
|
||||||
|
(proc (address->stob-descriptor (addr1+ addr)))
|
||||||
|
(loop (addr1+ (addr+ addr (header-a-units d)))))
|
||||||
|
(begin (chunk-end i)
|
||||||
|
(chunk-loop addr
|
||||||
|
(+ i 1)
|
||||||
|
(+ chunk *chunk-size*))))))))))
|
||||||
|
|
||||||
|
(define (mutable? x) (not (immutable? x)))
|
||||||
|
|
||||||
|
;; End begin
|
||||||
|
))
|
||||||
Loading…
Reference in New Issue