Changes to make the microcode work on OSX/Power PC.
Changes to make the microcode when compiled by a 64-bit compiler
(x86_64, Power PC, Itanium).
#!/bin/sh
#
-# $Id: Setup.sh,v 1.12 2004/12/07 04:29:58 cph Exp $
+# $Id: Setup.sh,v 1.13 2006/09/16 11:19:08 gjr Exp $
#
-# Copyright 2000,2001,2003,2004 Massachusetts Institute of Technology
+# Copyright 2000,2001,2003,2004,2006 Massachusetts Institute of Technology
#
# This file is part of MIT/GNU Scheme.
#
# lib
maybe_mkdir lib
maybe_link lib/SRC ..
+maybe_link lib/include ../microcode
maybe_link lib/optiondb.scm ../etc/optiondb.scm
maybe_link lib/options ../runtime
maybe_link lib/utabmd.bin ../microcode/utabmd.bin
maybe_link lib/edwin/etc/mime.types ../../../etc/mime.types
maybe_link lib/edwin/autoload ../../edwin
-for SUBDIR in 6001 compiler cref edwin imail microcode rcs \
- runtime runtime-check sf sos ssp star-parser win32 xdoc xml; do
+for SUBDIR in 6001 compiler cref edwin imail rcs runtime runtime-check \
+ sf sos ssp star-parser win32 xdoc xml microcode; do
echo "setting up ${SUBDIR}"
maybe_link ${SUBDIR}/Setup.sh ../etc/Setup.sh
( cd ${SUBDIR} && ./Setup.sh ) || exit 1
#| -*-Scheme-*-
-$Id: toplev.scm,v 4.64 2003/02/14 18:28:01 cph Exp $
+$Id: toplev.scm,v 4.65 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1988-2001 Massachusetts Institute of Technology
+Copyright (c) 1988-2001, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define compile-file:override-usual-integrations '())
(define compile-file:sf-only? #f)
(define compile-file:force? #f)
+(define compiler:compile-data-files-as-expressions? #t)
(define compile-file)
(let ((scm-pathname (lambda (path) (pathname-new-type path "scm")))
(bin-pathname (lambda (path) (pathname-new-type path "bin")))
(ext-pathname (lambda (path) (pathname-new-type path "ext")))
- (com-pathname (lambda (path) (pathname-new-type path "com"))))
+ (com-pathname (lambda (path)
+ (pathname-new-type path compiled-output-extension))))
(define (process-file input-file output-file dependencies processor)
(let ((doit (lambda () (processor input-file output-file dependencies))))
(and (not (default-object? output-string)) output-string)
(make-pathname #f #f #f #f "bin" 'NEWEST)
(lambda (input-pathname output-pathname)
- (maybe-open-file
- compiler:generate-rtl-files?
- (pathname-new-type output-pathname "rtl")
- (lambda (rtl-output-port)
- (maybe-open-file compiler:generate-lap-files?
- (pathname-new-type output-pathname "lap")
- (lambda (lap-output-port)
- (fluid-let ((*debugging-key*
- (random-byte-vector 32)))
- (compile-scode/internal
- (compiler-fasload input-pathname)
- (pathname-new-type output-pathname "inf")
- rtl-output-port
- lap-output-port))))))))
+ (let ((scode (compiler-fasload input-pathname)))
+ (if (and (scode/constant? scode)
+ (not compiler:compile-data-files-as-expressions?))
+ (compile-data-from-file scode output-pathname)
+ (maybe-open-file
+ compiler:generate-rtl-files?
+ (pathname-new-type output-pathname "rtl")
+ (lambda (rtl-output-port)
+ (maybe-open-file
+ compiler:generate-lap-files?
+ (pathname-new-type output-pathname "lap")
+ (lambda (lap-output-port)
+ (fluid-let ((*debugging-key*
+ (random-byte-vector 32)))
+ (compile-scode/internal
+ scode
+ (pathname-new-type output-pathname "inf")
+ rtl-output-port
+ lap-output-port))))))))))
unspecific)))
(define *debugging-key*)
(newline)))
(compiler-file-output
(transform input-pathname output-pathname)
- output-pathname)))))
+ output-pathname)))))
(kernel
(if compiler:batch-mode?
(batch-kernel core)
(if (scode/comment? scode)
(scode/comment-expression scode)
scode))))
- (if (scode/open-block? scode)
- (scode/open-block-components scode
- (lambda (names declarations body)
- (if (null? names)
- (scan-defines body
- (lambda (names declarations* body)
- (make-open-block names
- (append declarations declarations*)
- body)))
- scode)))
- (scan-defines scode make-open-block))))
+ (cond ((scode/constant? scode)
+ scode)
+ ((scode/open-block? scode)
+ (scode/open-block-components
+ scode
+ (lambda (names declarations body)
+ (if (null? names)
+ (scan-defines
+ body
+ (lambda (names declarations* body)
+ (make-open-block names
+ (append declarations declarations*)
+ body)))
+ scode))))
+ (else
+ (scan-defines scode make-open-block)))))
\f
;;;; Alternate Entry Points
#| -*-Scheme-*-
-$Id: utils.scm,v 4.30 2006/09/08 14:38:45 cph Exp $
+$Id: utils.scm,v 4.31 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
Copyright 1994,2001,2001,2003,2004,2006 Massachusetts Institute of Technology
'|#[delay-lambda]|)
(define (non-pointer-object? object)
- ;; Use of OBJECT-NON-POINTER? appears to cause problems.
- ;; This should be figured out when I have more time. -- cph
+ ;; We can't use `object/non-pointer?' here because the C
+ ;; back-end requires more stringent constraints on fixnums.
+ ;; It may have other constraints on other types
(or (object-type? (ucode-type false) object)
(object-type? (ucode-type true) object)
- (fix:fixnum? object)
+ (and (fix:fixnum? object)
+ (fix:< object signed-fixnum/upper-limit)
+ (not (fix:< object signed-fixnum/lower-limit)))
(object-type? (ucode-type character) object)
(object-type? (ucode-type unassigned) object)
(object-type? (ucode-type the-environment) object)
#!/bin/sh
-# $Id: configure,v 1.6 2003/02/14 18:28:00 cph Exp $
+# $Id: configure,v 1.7 2006/09/16 11:19:09 gjr Exp $
#
-# Copyright (c) 2000 Massachusetts Institute of Technology
+# Copyright (c) 2000, 2006 Massachusetts Institute of Technology
#
# This file is part of MIT/GNU Scheme.
#
MACHINE=vax
;;
* )
- echo "Unable to determine machine type."
- exit 1
+ MACHINE=C
;;
esac
ln -s machines/${MACHINE} machine
#| -*-Scheme-*-
-$Id: fggen.scm,v 4.39 2003/02/14 18:28:01 cph Exp $
+$Id: fggen.scm,v 4.40 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001, 2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(declare (usual-integrations))
\f
+;; Note: The C back end cannot dump objects, and instead generates
+;; code to construct the objects.
+;; Thus the unmapping of reference traps must be done late,
+;; when generating such code, and not early, since the code
+;; that destructures object will otherwise run into actual
+;; reference traps.
+
+(define compiler:fggen-unmap-reference-traps-early? true)
+
(define-structure (context (conc-name context/)
(constructor context/make))
(unconditional? #f read-only #t type boolean)
block continuation context
(list->vector
(map (lambda (subpr)
- (unmap-reference-trap
- (constant-value (subproblem-rvalue subpr))))
+ (let ((temp (constant-value (subproblem-rvalue subpr))))
+ (if compiler:fggen-unmap-reference-traps-early?
+ (unmap-reference-trap temp)
+ temp)))
operands)))
(generate/operator block continuation context expression
(ucode-primitive vector)
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.16 2003/02/14 18:28:01 cph Exp $
+$Id: compiler.pkg,v 1.17 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
"base/sets" ;set abstraction
"base/mvalue" ;multiple-value support
"base/scode" ;SCode abstraction
- "rtlbase/valclass" ;RTL: value classes
"machines/C/machin" ;machine dependent stuff
"machines/C/cutl" ;back-end odds and ends
"base/utils" ;odds and ends
"rtlbase/rtlcfg" ;RTL: CFG types
"rtlbase/rtlobj" ;RTL: CFG objects
"rtlbase/regset" ;RTL: register sets
+ "rtlbase/valclass" ;RTL: value classes
"back/insseq" ;LAP instruction sequences
)
compiler:implicit-self-static?
compiler:intersperse-rtl-in-lap?
compiler:noisy?
+ compiler:open-code-floating-point-arithmetic?
compiler:open-code-flonum-checks?
compiler:open-code-primitives?
compiler:optimize-environments?
(define-package (compiler macros)
(files "base/macros")
- (parent ())
- (import (runtime macros)
- parse-define-syntax)
- (initialization (initialize-package!)))
+ (parent (compiler))
+ (export (compiler)
+ cfg-node-case
+ define-enumeration
+ define-export
+ define-lvalue
+ define-pnode
+ define-root-type
+ define-rtl-expression
+ define-rtl-predicate
+ define-rtl-statement
+ define-rule
+ define-rvalue
+ define-snode
+ define-vector-slots
+ descriptor-list
+ enumeration-case
+ inst-ea
+ lap
+ last-reference
+ make-lvalue
+ make-pnode
+ make-rvalue
+ make-snode
+ package
+ rule-matcher)
+ (import (runtime syntactic-closures)
+ syntax-match?))
(define-package (compiler declarations)
(files "machines/C/decls")
cbf
cf
compile-bin-file
+ compile-file
+ compile-file:force?
+ compile-file:override-usual-integrations
+ compile-file:sf-only?
compile-procedure
compile-scode
compiler:c-compiler-name
compiler:reset!
;; cross-compile-bin-file
;; cross-compile-bin-file-end
+ ;; lap->code
)
(export (compiler)
canonicalize-label-name)
*block-label*
*disambiguator*
*external-labels*
+ *shared-namestring*
*special-labels*
label->object
*invoke-interface*
(export (compiler)
make-pattern-variable
pattern-lookup
+ pattern-lookup-1
pattern-variable-name
pattern-variable?
pattern-variables))
(files "base/pmpars")
(parent (compiler))
(export (compiler)
+ make-rule-matcher
parse-rule
+ rule->matcher
rule-result-expression)
(export (compiler macros)
+ make-rule-matcher
parse-rule
+ rule->matcher
rule-result-expression))
(define-package (compiler pattern-matcher/early)
(export (compiler top-level)
rtl-rewriting:post-cse
rtl-rewriting:pre-cse)
- (export (compiler lap-syntaxer) add-rewriting-rule!))
+ (export (compiler lap-syntaxer)
+ add-rewriting-rule!
+ add-pre-cse-rewriting-rule!))
(define-package (compiler rtl-optimizer lifetime-analysis)
(files "rtlopt/rlife")
(files "back/lapgn1" ;LAP generator
"back/lapgn2" ; " "
"back/regmap" ;Hardware register allocator
- "machines/C/cout" ;converts partial C code into one one big string
+ "machines/C/cout" ;converts partial C code
+ ; into one one big string
"machines/C/lapgen" ;code generation rules
"machines/C/rules1" ; " " "
"machines/C/rules2" ; " " "
"machines/C/rulfix" ; " " "
"machines/C/rulflo" ; " " "
"machines/C/rulrew" ;code rewriting rules
+ "machines/C/traditional" ;traditional object construction
+ "machines/C/stackify" ;denser object construction
+ "machines/C/stackops" ;denser object construction
)
(parent (compiler))
(export ()
*C-procedure-name*)
(export (compiler)
available-machine-registers
- fits-in-16-bits-signed?
- fits-in-16-bits-unsigned?
- top-16-bits-only?
lap-generator/match-rtl-instruction
lap:make-entry-point
lap:make-label-statement
- lap:make-unconditional-branch
- lap:syntax-instruction)
+ lap:make-unconditional-branch)
(export (compiler top-level)
*block-associations*
current-register-list
make-table
objects
permanent-register-list
- stringify)
+ stringify
+ stringify-data)
+ (import (runtime string)
+ %string-append)
(import (scode-optimizer expansion)
scode->scode-expander))
#| -*-Scheme-*-
-$Id: compiler.sf,v 1.11 2003/02/14 18:28:02 cph Exp $
+$Id: compiler.sf,v 1.12 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999, 2001 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2001, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
(let ((sf-and-load
(lambda (files package)
- (sf-conditionally files)
+ (fluid-let ((sf/default-syntax-table (->environment package)))
+ (sf-conditionally files))
(for-each (lambda (file)
(load (string-append file ".bin") package))
files))))
(newline)
(sf-and-load '("base/switch") '(COMPILER))
(sf-and-load '("base/macros") '(COMPILER MACROS))
- ((access initialize-package! (->environment '(COMPILER MACROS))))
(sf-and-load '("machines/C/decls") '(COMPILER DECLARATIONS))
(let ((environment (->environment '(COMPILER DECLARATIONS))))
(set! (access source-file-expression environment) "*.scm")
((access initialize-package! environment)))
(sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
(sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
- (sf-and-load '("rtlbase/valclass") '(COMPILER))
- (fluid-let ((sf/default-syntax-table (->environment '(COMPILER))))
- (sf-and-load '("machines/C/machin") '(COMPILER)))
- (set! (access endianness (->environment '(COMPILER))) 'BIG)
+ (sf-and-load '("machines/C/machin") '(COMPILER))
(sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
(sf-and-load '("base/scode") '(COMPILER))
- (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
+ (sf-and-load '("back/syerly") '(COMPILER LAP-SYNTAXER))))
;; Resyntax any files that need it.
((access syntax-files! (->environment '(COMPILER))))
#| -*-Scheme-*-
-$Id: cout.scm,v 1.23 2003/02/14 18:28:02 cph Exp $
+$Id: cout.scm,v 1.24 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(declare (usual-integrations))
\f
-(define *C-procedure-name* 'DEFAULT)
+(define-syntax let*/mv
+ (rsc-macro-transformer
+ (lambda (form environment)
+ environment ; unused
+ (let ((body (cddr form)))
+ (let recur ((bindings (cadr form)))
+ (cond ((null? bindings)
+ `(BEGIN
+ ,@body))
+ ((not (pair? (caar bindings)))
+ `(LET (,(car bindings))
+ ,(recur (cdr bindings))))
+ (else
+ (let ((values-names (caar bindings))
+ (values-form (cadar bindings)))
+ `(WITH-VALUES (LAMBDA () ,values-form)
+ (LAMBDA ,values-names
+ ,(recur (cdr bindings))))))))))))
+\f
+(define *use-stackify?* true)
(define *disable-timestamps?* false)
+(define *C-procedure-name* 'DEFAULT)
+(define *subblocks*) ;referenced by stackify
+
+(define (stringify-data object output-pathname)
+ (if (not *use-stackify?*)
+ (stringify-data/traditional object output-pathname)
+ (stringify-data/stackify object output-pathname)))
+
+(define (stringify-data/stackify object output-pathname)
+ (let* ((str (stackify 0 object))
+ (handle (or (and output-pathname
+ (let ((dir (pathname-directory output-pathname)))
+ (string-append
+ (if (or (not dir) (null? dir))
+ ""
+ (car (last-pair dir)))
+ "_"
+ (pathname-name output-pathname))))
+ "handle"))
+ (data-name
+ (canonicalize-label-name
+ (string-append handle "_data" (make-time-stamp)))))
+
+ (list-of-strings->string
+ (append (file-prefix)
+ (file-header 0 handle #f #f #f data-name)
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (stackify-output->data-decl "prog" str)
+ (list "\n")
+ (object-function-header/stackify data-name)
+ (list "\tDECLARE_VARIABLES_FOR_OBJECT();\n\n")
+ (list
+ "\treturn (unstackify (((unsigned char *) (& prog[0])), 0));")
+ (function-trailer data-name)
+ (list "#endif /* WANT_ONLY_CODE */\n")))))
+
+(define (stringify-data/traditional object output-pathname)
+ (let*/mv (((vars prefix suffix) (handle-top-level-data/traditional object))
+ (handle (or (and output-pathname
+ (let ((dir (pathname-directory output-pathname)))
+ (string-append
+ (if (or (not dir) (null? dir))
+ ""
+ (car (last-pair dir)))
+ "_"
+ (pathname-name output-pathname))))
+ "handle"))
+ (data-name
+ (canonicalize-label-name
+ (string-append handle "_data" (make-time-stamp)))))
+
+ (list-of-strings->string
+ (append (file-prefix)
+ (file-header 0 handle #f #f #f data-name)
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (object-function-header/traditional data-name)
+ (->variable-declarations vars)
+ (list "\tDECLARE_VARIABLES_FOR_OBJECT();\n")
+ (list "\n\t")
+ prefix
+ suffix
+ (list "\n\treturn (top_level_object);\n")
+ (function-trailer data-name)
+ (list "#endif /* WANT_ONLY_CODE */\n")))))
+\f
(define (stringify suffix initial-label lap-code info-output-pathname)
- (define (stringify-object x)
- (cond ((string? x)
- x)
- ((symbol? x)
- (%symbol->string x))
- ((number? x)
- (number->string x))
- (else
- (error "stringify: Unknown frob" x))))
-
- (define (make-time-stamp)
- (if *disable-timestamps?*
- "_timestamp"
- (let ((time (get-decoded-time)))
- (string-append
- "_"
- (number->string (decoded-time/second time)) "_"
- (number->string (decoded-time/minute time)) "_"
- (number->string (decoded-time/hour time)) "_"
- (number->string (decoded-time/day time)) "_"
- (number->string (decoded-time/month time)) "_"
- (number->string (decoded-time/year time))))))
-
- (define (->variable-declarations vars)
- (if (null? vars)
- (list "")
- `("\tSCHEME_OBJECT\n\t "
- ,(car vars)
- ,@(append-map (lambda (var)
- (list ",\n\t " var))
- (cdr vars))
- ";\n")))
-
- (define (choose-proc-name default midfix time-stamp)
+ ;; returns <code-name data-name ntags symbol-table code proxy>
+ (define (canonicalize-name name full?)
+ (if full?
+ (canonicalize-label-name name)
+ (C-quotify-string name)))
+
+ (define (choose-name full? default midfix time-stamp)
(let ((path (and info-output-pathname
(merge-pathnames
(if (pair? info-output-pathname)
(string-append default suffix time-stamp))
((or (string-null? suffix) *disable-timestamps?*)
(let ((dir (pathname-directory path)))
- (string-append (if (or (not dir) (null? dir))
- default
- (canonicalize-label-name
- (car (last-pair dir))))
- "_"
- (canonicalize-label-name (pathname-name path))
- midfix
- suffix)))
+ (string-append
+ (if (or (not dir) (null? dir))
+ default
+ (canonicalize-name (car (last-pair dir)) full?))
+ "_"
+ (canonicalize-name (pathname-name path) full?)
+ midfix
+ suffix)))
(else
- (string-append (canonicalize-label-name (pathname-name path))
- "_"
- default
- suffix
- time-stamp)))))
+ (string-append
+ (canonicalize-name (pathname-name path) full?)
+ "_"
+ default
+ suffix
+ time-stamp)))))
\f
+ (define (gen-code-name time-stamp)
+ (choose-name true "code" "" time-stamp))
+
+ (define (gen-data-name time-stamp)
+ (choose-name true "data" "_data" time-stamp))
+
+ (define (gen-handle-name time-stamp)
+ (choose-name false "" "" time-stamp))
+
(define (subroutine-information-1)
(cond ((eq? *invoke-interface* 'INFINITY)
(values (list "") (list "")))
((< *invoke-interface* 5)
(values (list-tail (list
- "\ninvoke_interface_0:\n\tutlarg_1 = 0;\n"
- "\ninvoke_interface_1:\n\tutlarg_2 = 0;\n"
- "\ninvoke_interface_2:\n\tutlarg_3 = 0;\n"
- "\ninvoke_interface_3:\n\tutlarg_4 = 0;\n"
- "\ninvoke_interface_4:\n\t"
+ "\nDEFLABEL(invoke_interface_0);\n"
+ "\tutlarg_1 = 0;\n"
+ "\nDEFLABEL(invoke_interface_1);\n"
+ "\tutlarg_2 = 0;\n"
+ "\nDEFLABEL(invoke_interface_2);\n"
+ "\tutlarg_3 = 0;\n"
+ "\nDEFLABEL(invoke_interface_3);\n"
+ "\tutlarg_4 = 0;\n"
+ "\nDEFLABEL(invoke_interface_4);\n\t"
"INVOKE_INTERFACE_CODE ();\n")
*invoke-interface*)
(list "\tint utlarg_code;\n"
(define (subroutine-information-2)
(if *used-invoke-primitive*
- (values (list "\ninvoke_primitive:\n\t"
+ (values (list "\nDEFLABEL(invoke_primitive);\n\t"
"INVOKE_PRIMITIVE_CODE ();")
(list "\tSCHEME_OBJECT primitive;\n"
"\tlong primitive_nargs;\n"))
(values (list "") (list ""))))
(define (subroutine-information)
- (with-values subroutine-information-1
- (lambda (code-1 vars-1)
- (with-values subroutine-information-2
- (lambda (code-2 vars-2)
- (values (append code-1 code-2)
- (append vars-1 vars-2)))))))
+ (let*/mv (((code-1 vars-1) (subroutine-information-1))
+ ((code-2 vars-2) (subroutine-information-2)))
+ (values (append code-1 code-2)
+ (append vars-1 vars-2))))
(if *purification-root-object*
(define-object "PURIFICATION_ROOT"
(define-object (special-label/debugging)
(let frob ((obj info-output-pathname))
(cond ((pathname? obj)
- (->namestring obj))
+ (->namestring/shared obj))
((pair? obj)
(cons (frob (car obj))
(frob (cdr obj))))
(define-object (special-label/environment) unspecific)
\f
- (let ((n 1) ; First word is vector header
- (initial-offset (label->offset initial-label)))
- (with-values (lambda () (handle-labels n))
- (lambda (n ntags
- label-defines label-dispatch
- label-block-initialization symbol-table)
- (with-values (lambda () (handle-free-refs-and-sets n))
- (lambda (n free-defines free-block-initialization free-symbols)
- (with-values (lambda () (handle-objects n))
- (lambda (n decl-code decl-data
- xtra-procs object-prefix
- object-defines temp-vars
- object-block-initialization)
- (let* ((time-stamp (make-time-stamp))
- (code-name
- (choose-proc-name "code" "" time-stamp))
- (data-name
- (choose-proc-name "data" "_data" time-stamp))
- (decl-code-name (string-append "decl_" code-name))
- (decl-data-name (string-append "decl_" data-name)))
- (with-values subroutine-information
- (lambda (extra-code extra-variables)
- (values
- code-name
- data-name
- ntags
- (cons* (cons (special-label/environment)
- (-1+ n))
- (cons (special-label/debugging)
- (- n 2))
- (append free-symbols symbol-table))
- (list-of-strings->string
- (map (lambda (x)
- (list-of-strings->string x))
- (list
- (if (string-null? suffix)
- (append
- (file-prefix)
- (list
- "#ifndef WANT_ONLY_DATA\n"
- ;; This must be a single line!
- "DECLARE_COMPILED_CODE (\"" code-name
- "\", " (number->string ntags)
- ", " decl-code-name
- ", " code-name ")\n"
- "#endif /* WANT_ONLY_DATA */\n\n"
- "#ifndef WANT_ONLY_CODE\n"
- ;; This must be a single line!
- "DECLARE_COMPILED_DATA (\"" code-name
- "\", " decl-data-name
- ", " data-name ")\n"
- "#endif /* WANT_ONLY_CODE */\n\n"
- "DECLARE_DYNAMIC_INITIALIZATION (\""
- code-name "\")\n\n"))
- '())
- xtra-procs
-
- (if (string-null? suffix)
- (append
- (list "#ifndef WANT_ONLY_DATA\n")
- (list
- "int\n"
- "DEFUN_VOID (" decl-code-name ")\n{\n\t")
- decl-code
- (list "return (0);\n}\n"
- "#endif /* WANT_ONLY_DATA */\n\n")
- (list "#ifndef WANT_ONLY_CODE\n")
- (list
- "int\n"
- "DEFUN_VOID (" decl-data-name ")\n{\n\t")
- decl-data
- (list "return (0);\n}\n"
- "#endif /* WANT_ONLY_CODE */\n\n"))
- '())
-
- label-defines
- object-defines
- free-defines
- (list "\n")
-
- (list "#ifndef WANT_ONLY_CODE\n")
- (let ((header (data-function-header data-name)))
- (if (string-null? suffix)
- header
- (cons "static " header)))
- (list "\tSCHEME_OBJECT object"
- " = (ALLOCATE_VECTOR ("
- (number->string (- n 1))
- "L));\n"
- "\tSCHEME_OBJECT * current_block"
- " = (OBJECT_ADDRESS (object));\n")
- (->variable-declarations temp-vars)
- (list "\n\t")
- object-prefix
- label-block-initialization
- free-block-initialization
- object-block-initialization
- (list "\n\treturn (¤t_block["
- (stringify-object initial-offset)
- "]);\n")
- (function-trailer data-name)
- (list "#endif /* WANT_ONLY_CODE */\n")
- (list "\n")
-
- (list "#ifndef WANT_ONLY_DATA\n")
- (let ((header (code-function-header code-name)))
- (if (string-null? suffix)
- header
- (cons "static " header)))
- (function-decls)
- (register-declarations)
- extra-variables
- (list
- "\n\tgoto perform_dispatch;\n\n"
- "pop_return:\n\t"
- "Rpc = (OBJECT_ADDRESS (*Rsp++));\n\n"
- "perform_dispatch:\n\n\t"
- "switch ((* ((unsigned long *) Rpc))"
- " - dispatch_base)\n\t{")
- label-dispatch
- (list
- "\n\t default:\n\t\t"
- "UNCACHE_VARIABLES ();\n\t\t"
- "return (Rpc);\n\t}\n\t")
- (map stringify-object lap-code)
- extra-code
- (function-trailer code-name)
- (list
- "#endif /* WANT_ONLY_DATA */\n"))))))))))))))))
+ (let*/mv ((label-offset 1) ; First word is vector header
+ (initial-offset (label->offset initial-label))
+ ((first-free-offset ntags label-defines label-dispatch
+ label-block-initialization symbol-table)
+ (handle-labels label-offset))
+ ((first-object-offset free-defines
+ free-block-initialization free-symbols)
+ (handle-free-refs-and-sets first-free-offset))
+ ((cc-block-size decl-code decl-data
+ xtra-procs object-prefix
+ object-defines temp-vars
+ object-block-initialization)
+ (handle-objects first-object-offset))
+ (time-stamp (make-time-stamp))
+ (handle (gen-handle-name time-stamp))
+ (code-name (gen-code-name time-stamp))
+ (data-name (gen-data-name time-stamp))
+ (decl-code-name (string-append "decl_" code-name))
+ (decl-data-name (string-append "decl_" data-name))
+ ((extra-code extra-variables)
+ (subroutine-information))
+ ((proxy xtra-procs* decl-code* decl-data* data-prefix data-body)
+ (data-function-body (string-null? suffix)
+ ntags
+ data-name
+ initial-offset
+ cc-block-size
+ temp-vars
+ object-prefix
+ label-block-initialization
+ free-block-initialization
+ object-block-initialization))
+ (use-stackify? *use-stackify?*))
+ (values
+ code-name
+ data-name
+ ntags
+ (cons* (cons (special-label/environment)
+ (- cc-block-size 1))
+ (cons (special-label/debugging)
+ (- cc-block-size 2))
+ (append free-symbols symbol-table))
+ (list-of-strings->string
+ (map (lambda (x)
+ (list-of-strings->string x))
+ (list
+ (if (string-null? suffix)
+ (file-prefix)
+ '())
+
+ ;; Extra code
+
+ xtra-procs
+ xtra-procs*
+
+ ;; defines for the code
+
+ label-defines
+ object-defines
+ free-defines
+ (list "\n")
+
+ ;; the code itself
+
+ (list "#ifndef WANT_ONLY_DATA\n")
+ (let ((header (code-function-header code-name)))
+ (if (string-null? suffix)
+ header
+ (cons "static " header)))
+ (function-decls)
+ (register-declarations)
+ extra-variables
+ (list
+ "\n"
+ ;; The assignment is necessary to ensure that we restart properly
+ ;; after an interrupt when the dynamic link is live
+ ;; (see DLINK_INTERRUPT_CHECK and comp_interrupt_restart
+ "\tRdl = (OBJECT_ADDRESS (Rvl));\n"
+ "\tgoto perform_dispatch;\n\n"
+ "DEFLABEL(pop_return);\n\t"
+ "Rpc = (OBJECT_ADDRESS (*Rsp++));\n\n"
+ "DEFLABEL(perform_dispatch);\n\n\t"
+ "switch ((* ((unsigned long *) Rpc))"
+ " - dispatch_base)\n\t{")
+ label-dispatch
+ (list
+ "\n\t default:\n\t\t"
+ "UNCACHE_VARIABLES ();\n\t\t"
+ "return (Rpc);\n\t}\n\t")
+ (map stringify-object lap-code)
+ extra-code
+ (function-trailer code-name)
+ (list
+ "#endif /* WANT_ONLY_DATA */\n")
+
+ (if (and (string-null? suffix) use-stackify?)
+ (list "\f\n")
+ '())
+
+ ;; the data generator
+
+ data-prefix
+
+ (if (or (string-null? suffix)
+ (not use-stackify?))
+ (append
+ (list "\n")
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (let ((header (data-function-header data-name)))
+ (if (string-null? suffix)
+ header
+ (cons "static " header)))
+ data-body
+ (function-trailer data-name)
+ (list "#endif /* WANT_ONLY_CODE */\n"))
+ '())
+
+ ;; File footer
+
+ (if (and (string-null? suffix) use-stackify?)
+ (list "\f\n")
+ '())
+
+ (cond ((not (string-null? suffix))
+ '())
+ ((not use-stackify?)
+ (file-decls/traditional decl-code-name
+ decl-code
+ decl-data-name
+ decl-data))
+ (else
+ (file-decls/stackify decl-code-name
+ decl-code*
+ decl-data-name
+ decl-data*)))
+
+ (if (string-null? suffix)
+ (file-header ntags handle
+ decl-code-name code-name
+ decl-data-name data-name)
+ '())
+ )))
+ proxy)))
+\f
+(define (data-function-body top-level?
+ ntags
+ data-name
+ initial-offset
+ cc-block-size
+ temp-vars
+ object-prefix
+ label-block-initialization
+ free-block-initialization
+ object-block-initialization)
+ ;; returns <proxy xtra-procs decl-code decl-data data-prefix data-body>
+ (cond ((not *use-stackify?*)
+ (values
+ #f ; proxy
+ '() ; xtra-procs
+ #f ; decl-code
+ #f ; decl-data
+ '() ; data-prefix
+ (map (lambda (x) (list-of-strings->string x))
+ (list (list "\tSCHEME_OBJECT object"
+ " = (ALLOCATE_VECTOR ("
+ (number->string (- cc-block-size 1))
+ "L));\n"
+ "\tSCHEME_OBJECT * current_block"
+ " = (OBJECT_ADDRESS (object));\n")
+ (->variable-declarations temp-vars)
+ (list "\tDECLARE_VARIABLES_FOR_DATA();\n")
+ (list "\n\t")
+ object-prefix
+ label-block-initialization
+ free-block-initialization
+ object-block-initialization
+ (list "\n\treturn (¤t_block["
+ (stringify-object initial-offset)
+ "]);\n")))))
+ ((or (not (null? temp-vars))
+ (not (null? object-prefix)))
+ (error "data-function-body: stackify inconsistency"))
+ ((not top-level?)
+ (values
+ (list->vector (append label-block-initialization
+ free-block-initialization
+ object-block-initialization))
+ '() ; xtra-procs
+ '() ; decl-code
+ '() ; decl-data
+ '() ; data-prefix
+ '() ; data-body
+ ))
+ (else
+ (fluid-let ((*subblocks* '()))
+ (let ((name (string-append "prog_" data-name))
+ (str
+ (stackify
+ ntags
+ (list->vector (append label-block-initialization
+ free-block-initialization
+ object-block-initialization)))))
+
+ (set! *subblocks* (reverse! *subblocks*))
+ (values
+ #f ; proxy
+ (append-map fake-block->c-code *subblocks*) ; xtra-procs*
+ *subblocks* ; decl-code
+ '() ; decl-data
+ (append
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (stackify-output->data-decl name str)
+ (list "#endif /* WANT_ONLY_CODE */\n"))
+ (list
+ "\tSCHEME_OBJECT ccb, * current_block;\n"
+ "\tDECLARE_VARIABLES_FOR_DATA();\n\n"
+ "\tccb = (unstackify (((unsigned char *)\n"
+ "\t (& " name "[0])),\n"
+ "\t dispatch_base));\n"
+ "\tcurrent_block = (OBJECT_ADDRESS (ccb));\n"
+ "\treturn (& current_block["
+ (stringify-object initial-offset)
+ "]);")))))))
\f
+(define (stackify-output->data-decl name str)
+ (append (list "static CONST unsigned char "
+ name
+ "["
+ (number->string (string-length str))
+ "] =\n")
+ (C-quotify-data-string/breakup str)
+ (list ";\n")))
+
(define-integrable (list-of-strings->string strings)
- (apply string-append strings))
+ (%string-append strings))
(define-integrable (%symbol->string sym)
(system-pair-car sym))
-(define (file-prefix)
- (let ((time (get-decoded-time)))
- (list "/* Emacs: this is properly parenthesized -*- C -*- code.\n"
- " Thank God it was generated by a machine.\n"
- " */\n\n"
- "/* C code produced\n "
- (decoded-time/date-string time)
- " at "
- (decoded-time/time-string time)
- "\n by Liar version "
- (or (get-subsystem-version-string "liar") "?.?")
- ".\n */\n\n"
- "#include \"liarc.h\"\n\n")))
-
(define (code-function-header name)
(list "SCHEME_OBJECT *\n"
"DEFUN (" name ", (Rpc, dispatch_base),\n\t"
- "SCHEME_OBJECT * Rpc AND unsigned long dispatch_base)\n"
+ "SCHEME_OBJECT * Rpc AND entry_count_t dispatch_base)\n"
"{\n"))
(define (data-function-header name)
(list "SCHEME_OBJECT *\n"
- "DEFUN (" name ", (dispatch_base), unsigned long dispatch_base)\n"
+ "DEFUN (" name ", (dispatch_base), entry_count_t dispatch_base)\n"
+ "{\n"))
+
+(define (object-function-header/traditional name)
+ (list "SCHEME_OBJECT\n"
+ "DEFUN_VOID (" name ")\n"
+ "{\n\tSCHEME_OBJECT top_level_object;\n"))
+
+(define (object-function-header/stackify name)
+ (list "SCHEME_OBJECT\n"
+ "DEFUN_VOID (" name ")\n"
"{\n"))
(define (function-decls)
(list
"\tREGISTER SCHEME_OBJECT * current_block;\n"
- "\tSCHEME_OBJECT * Rdl;\n"
- "\tDECLARE_VARIABLES ();\n"))
+ "\tDECLARE_VARIABLES ();\n"
+ ;; Rdl is initialized right before perform_dispatch.
+ "\tSCHEME_OBJECT * Rdl;\n"))
(define (function-trailer name)
(list "\n} /* End of " name ". */\n"))
(number->string val)
val)
"\n"))
-\f
-;;;; Object constructors
-
-(define new-variables)
-(define *subblocks*)
-(define num)
-
-(define (generate-variable-name)
- (set! new-variables
- (cons (string-append "tmpObj" (number->string num))
- new-variables))
- (set! num (1+ num))
- (car new-variables))
-
-(define-integrable (table/find table value)
- ;; assv ?
- (assq value table))
-
-(define-integrable (guaranteed-fixnum? value)
- (and (exact-integer? value)
- (<= signed-fixnum/lower-limit value)
- (< value signed-fixnum/upper-limit)))
-
-(define-integrable (guaranteed-long? value)
- (and (exact-integer? value)
- (<= guaranteed-long/lower-limit value)
- (< value guaranteed-long/upper-limit)))
-
-(define trivial-objects
- (list #f #t '() unspecific))
-
-(define (trivial? object)
- (or (memq object trivial-objects)
- (guaranteed-fixnum? object)))
-
-(define *depth-limit* 2)
-(define (name-if-complicated node depth)
- (cond ((fake-compiled-block? node)
- (let ((name (fake-block/name node)))
- (set! new-variables (cons name new-variables))
- name))
- ((or (%record? node)
- (vector? node)
- (> depth *depth-limit*))
- (generate-variable-name))
- (else
- false)))
-
-(define (build-table nodes)
- (map cdr
- (sort (sort/enumerate
- (list-transform-positive
- (let loop ((nodes nodes)
- (table '()))
- (if (null? nodes)
- table
- (loop (cdr nodes)
- (insert-in-table (car nodes)
- 0
- table))))
- (lambda (pair)
- (cdr pair))))
- (lambda (entry1 entry2)
- (let ((obj1 (cadr entry1))
- (obj2 (cadr entry2)))
- (if (not (fake-compiled-block? obj2))
- (or (fake-compiled-block? obj1)
- (< (car entry1) (car entry2)))
- (and (fake-compiled-block? obj1)
- (< (fake-block/index obj1)
- (fake-block/index obj2)))))))))
-\f
-;; Hack to make sort a stable sort
-
-(define (sort/enumerate l)
- (let loop ((l l) (n 0) (l* '()))
- (if (null? l)
- l*
- (loop (cdr l)
- (1+ n)
- (cons (cons n (car l))
- l*)))))
-
-(define (insert-in-table node depth table)
- (cond ((trivial? node)
- table)
- ((table/find table node)
- => (lambda (pair)
- (if (not (cdr pair))
- (set-cdr! pair (generate-variable-name)))
- table))
- (else
- (let* ((name (name-if-complicated node depth))
- (depth* (if name 1 (1+ depth)))
- (table (cons (cons node name) table)))
-
- (define-integrable (do-vector-like node vlength vref)
- (let loop ((table table)
- (i (vlength node)))
- (if (zero? i)
- table
- (let ((i-1 (-1+ i)))
- (loop (insert-in-table (vref node i-1)
- depth*
- table)
- i-1)))))
-
- (cond ((pair? node)
- ;; Special treatment on the CDR because of RCONSM.
- (insert-in-table
- (car node)
- depth*
- (insert-in-table (cdr node)
- (if name 1 depth)
- table)))
- ((vector? node)
- (do-vector-like node vector-length vector-ref))
- ((or (fake-compiled-procedure? node)
- (fake-compiled-block? node))
- table)
- ((%record? node)
- (do-vector-like node %record-length %record-ref))
- (else
- ;; Atom
- table))))))
-\f
-(define (top-level-constructor object&name)
- ;; (values prefix suffix)
- (let ((name (cdr object&name))
- (object (car object&name)))
- (cond ((pair? object)
- (values '()
- (list name " = (cons (SHARP_F, SHARP_F));\n\t")))
- ((fake-compiled-block? object)
- (set! *subblocks* (cons object *subblocks*))
- (values (list name " = (initialize_subblock (\""
- (fake-block/c-proc object)
- "\"));\n\t")
- '()))
- ((fake-compiled-procedure? object)
- (values '()
- (list name " = "
- (compiled-procedure-constructor
- object)
- ";\n\t")))
- ((vector? object)
- (values '()
- (list name " = (ALLOCATE_VECTOR ("
- (number->string (vector-length object))
- "));\n\t")))
- ((%record? object)
- (values '()
- (list name " = (ALLOCATE_RECORD ("
- (number->string (%record-length object))
- "));\n\t")))
- (else
- (values '()
- (list name "\n\t = "
- (->simple-C-object object)
- ";\n\t"))))))
-
-(define (top-level-updator object&name table)
- (let ((name (cdr object&name))
- (object (car object&name)))
-
- (define-integrable (do-vector-like object vlength vref vset-name)
- (let loop ((i (vlength object))
- (code '()))
- (if (zero? i)
- code
- (let ((i-1 (- i 1)))
- (loop i-1
- `(,vset-name " (" ,name ", "
- ,(number->string i-1) ", "
- ,(constructor (vref object i-1)
- table)
- ");\n\t"
- ,@code))))))
-
- (cond ((pair? object)
- (list "SET_PAIR_CAR (" name ", "
- (constructor (car object) table) ");\n\t"
- "SET_PAIR_CDR (" name ", "
- (constructor (cdr object) table) ");\n\t"))
- ((or (fake-compiled-block? object)
- (fake-compiled-procedure? object))
- '(""))
- ((%record? object)
- (do-vector-like object %record-length %record-ref "RECORD_SET"))
- ((vector? object)
- (do-vector-like object vector-length vector-ref "VECTOR_SET"))
- (else
- '("")))))
-\f
-(define (constructor object table)
- (let process ((object object))
- (cond ((table/find table object) => cdr)
- ((pair? object)
- (cond ((or (not (pair? (cdr object)))
- (table/find table (cdr object)))
- (string-append "(CONS (" (process (car object)) ", "
- (process (cdr object)) "))"))
- (else
- (let loop ((npairs 0)
- (object object)
- (frobs '()))
- (if (and (pair? object) (not (table/find table object)))
- (loop (1+ npairs)
- (cdr object)
- (cons (car object) frobs))
- ;; List is reversed to call rconsm
- (string-append
- "(RCONSM (" (number->string (1+ npairs))
- (apply string-append
- (map (lambda (frob)
- (string-append ",\n\t\t"
- (process frob)))
- (cons object frobs)))
- "))"))))))
- ((fake-compiled-procedure? object)
- (compiled-procedure-constructor object))
- ((or (fake-compiled-block? object)
- (vector? object)
- (%record? object))
- (error "constructor: Can't build directly"
- object))
- (else
- (->simple-C-object object)))))
-
-(define (compiled-procedure-constructor object)
- (string-append "(CC_BLOCK_TO_ENTRY ("
- (fake-procedure/block-name object)
- ", "
- (number->string
- (fake-procedure/label-index object))
- "))"))
+(define (file-prefix)
+ (let ((time (get-decoded-time)))
+ (list "/* Emacs: this is -*- C -*- code. */\n\n"
+ "/* C code produced\n "
+ (decoded-time/date-string time)
+ " at "
+ (decoded-time/time-string time)
+ "\n by Liar version "
+ (or (get-subsystem-version-string "liar") "?.?")
+ ".\n */\n\n"
+ "#include \"liarc.h\"\n\n")))
\f
-(define (top-level-constructors table)
- ;; (values prefix suffix)
- ;; (append-map top-level-constructor table)
- (let loop ((table (reverse table)) (prefix '()) (suffix '()))
- (if (null? table)
- (values prefix suffix)
- (with-values (lambda () (top-level-constructor (car table)))
- (lambda (prefix* suffix*)
- (loop (cdr table)
- (append prefix* prefix)
- (append suffix* suffix)))))))
-
-(define (->constructors names objects)
- ;; (values prefix-code suffix-code)
- (let* ((table (build-table objects)))
- (with-values (lambda () (top-level-constructors table))
- (lambda (prefix suffix)
- (values prefix
- (append suffix
- (append-map (lambda (object&name)
- (top-level-updator object&name table))
- table)
- (append-map
- (lambda (name object)
- (list (string-append name "\n\t = "
- (constructor object table)
- ";\n\t")))
- names
- objects)))))))
-
-(define (string-reverse string)
- (let* ((len (string-length string))
- (res (make-string len)))
- (do ((i (fix:- len 1) (fix:- i 1))
- (j 0 (fix:+ j 1)))
- ((fix:= j len) res)
- (string-set! res i (string-ref string j)))))
+(define (file-header ntags handle
+ decl-code-name code-name
+ decl-data-name data-name)
+ (if (= ntags 0)
+ (list "#ifndef WANT_ONLY_CODE\n"
+ ;; This must be a single line!
+ "DECLARE_DATA_OBJECT (\"" handle
+ "\", " data-name ")\n"
+ "#endif /* WANT_ONLY_CODE */\n\n"
+ "DECLARE_DYNAMIC_OBJECT_INITIALIZATION (\""
+ handle "\")\n")
+ (list "#ifndef WANT_ONLY_DATA\n"
+ ;; This must be a single line!
+ "DECLARE_COMPILED_CODE (\"" handle
+ "\", " (number->string ntags)
+ ", " decl-code-name
+ ", " code-name ")\n"
+ "#endif /* WANT_ONLY_DATA */\n\n"
+ "#ifndef WANT_ONLY_CODE\n"
+ ;; This must be a single line!
+ "DECLARE_COMPILED_DATA (\"" handle
+ "\", " (if *use-stackify?* "NO_SUBBLOCKS" decl-data-name)
+ ", " data-name ")\n"
+ "#endif /* WANT_ONLY_CODE */\n\n"
+ "DECLARE_DYNAMIC_INITIALIZATION (\""
+ handle "\")\n")))
+
+(define (make-time-stamp)
+ (if *disable-timestamps?*
+ "_timestamp"
+ (let ((time (get-decoded-time)))
+ (string-append
+ "_"
+ (number->string (decoded-time/second time)) "_"
+ (number->string (decoded-time/minute time)) "_"
+ (number->string (decoded-time/hour time)) "_"
+ (number->string (decoded-time/day time)) "_"
+ (number->string (decoded-time/month time)) "_"
+ (number->string (decoded-time/year time))))))
+
+(define (->variable-declarations vars)
+ (if (null? vars)
+ (list "")
+ `("\tSCHEME_OBJECT\n\t "
+ ,(car vars)
+ ,@(append-map (lambda (var)
+ (list ",\n\t " var))
+ (cdr vars))
+ ";\n")))
+
+(define (file-decls/traditional decl-code-name decl-code
+ decl-data-name decl-data)
+ (append (list "#ifndef WANT_ONLY_DATA\n")
+ (list
+ "int\n"
+ "DEFUN_VOID (" decl-code-name ")\n{\n")
+ decl-code
+ (list "\treturn (0);\n}\n"
+ "#endif /* WANT_ONLY_DATA */\n\n")
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (list
+ "int\n"
+ "DEFUN_VOID (" decl-data-name ")\n{\n")
+ decl-data
+ (list "\treturn (0);\n}\n"
+ "#endif /* WANT_ONLY_CODE */\n\n")))
\f
-(define (->simple-C-object object)
- (cond ((symbol? object)
- (let ((name (symbol->string object)))
- (string-append "(C_SYM_INTERN ("
- (number->string (string-length name))
- "L, \"" (C-quotify-string name) "\"))")))
- ((string? object)
- (string-append "(C_STRING_TO_SCHEME_STRING ("
- (number->string (string-length object))
- "L, \"" (C-quotify-string object) "\"))"))
- ((number? object)
- (let process ((number object))
- (cond ((flo:flonum? number)
- (string-append "(DOUBLE_TO_FLONUM ("
- (number->string number) "))"))
- ((guaranteed-long? number)
- (string-append "(LONG_TO_INTEGER ("
- (number->string number) "L))"))
- ((exact-integer? number)
- (let ((bignum-string
- (number->string (if (negative? number)
- (- number)
- number)
- 16)))
- (string-append "(DIGIT_STRING_TO_INTEGER ("
- (if (negative? number)
- "true, "
- "false, ")
- (number->string
- (string-length bignum-string))
- "L, \"" bignum-string "\"))")))
- ((and (exact? number) (rational? number))
- (string-append "(MAKE_RATIO ("
- (process (numerator number))
- ", " (process (denominator number))
- "))"))
- ((and (complex? number) (not (real? number)))
- (string-append "(MAKE_COMPLEX ("
- (process (real-part number))
- ", " (process (imag-part number))
- "))"))
- (else
- (error "scheme->C-object: Unknown number" number)))))
- ((eq? #f object)
- "SHARP_F")
- ((eq? #t object)
- "SHARP_T")
- ((primitive-procedure? object)
- (let ((arity (primitive-procedure-arity object)))
- (if (< arity -1)
- (error "scheme->C-object: Unknown arity primitive" object)
- (string-append "(MAKE_PRIMITIVE_PROCEDURE (\""
- (symbol->string
- (primitive-procedure-name object))
- "\", "
- (number->string arity)
- "))"))))
- ((char? object)
- (string-append "(MAKE_CHAR ("
- (let ((bits (char-bits object)))
- (if (zero? bits)
- "0"
- (string-append "0x" (number->string bits 16))))
- ", ((unsigned) "
- (C-quotify-char (make-char (char-code object) 0))
- ")))"))
- ((bit-string? object)
- (let ((string (number->string (bit-string->unsigned-integer object)
- 16)))
- (string-append "(DIGIT_STRING_TO_BIT_STRING ("
- (number->string (bit-string-length object)) "L, "
- (number->string (string-length string)) "L, \""
- (string-reverse string)
- "\"))")))
- ((null? object)
- "NIL")
- ((eq? object unspecific)
- "UNSPECIFIC")
- ((or (object-type? (ucode-type true) object)
- (object-type? (ucode-type false) object))
- ;; Random assorted objects, e.g.: #!rest, #!optional
- (string-append "(MAKE_OBJECT ("
- (if (object-type? (ucode-type true) object)
- "TC_TRUE"
- "TC_FALSE")
- ", "
- (number->string (object-datum object))
- "L))"))
- ;; Note: The following are here because of the Scode interpreter
- ;; and the runtime system.
- ;; They are not necessary for ordinary code.
- ((interpreter-return-address? object)
- (string-append "(MAKE_OBJECT (TC_RETURN_CODE, 0x"
- (number->string (object-datum object) 16)
- "))"))
- (else
- (error "->simple-C-object: unrecognized-type"
- object))))
+(define (file-decls/stackify decl-code-name code-blocks
+ decl-data-name data-blocks)
+ (append
+ (append (list "#ifndef WANT_ONLY_DATA\n")
+ (if (or (null? code-blocks)
+ (null? (cdr code-blocks)))
+ '()
+ (code-blocks->array-decl decl-code-name code-blocks))
+ (list
+ "int\n"
+ "DEFUN_VOID (" decl-code-name ")\n{\n")
+ (if (or (null? code-blocks)
+ (null? (cdr code-blocks)))
+ (map fake-block->code-decl
+ code-blocks)
+ (list "\tDECLARE_SUBCODE_MULTIPLE (arr_"
+ decl-code-name
+ ");\n"))
+ (list "\treturn (0);\n}\n"
+ "#endif /* WANT_ONLY_DATA */\n\n"))
+ (if *use-stackify?*
+ '()
+ (append
+ (list "#ifndef WANT_ONLY_CODE\n")
+ (if (or (null? data-blocks)
+ (null? (cdr data-blocks)))
+ '()
+ (data-blocks->array-decl decl-data-name data-blocks))
+ (list
+ "int\n"
+ "DEFUN_VOID (" decl-data-name ")\n{\n")
+ (if (or (null? data-blocks)
+ (null? (cdr data-blocks)))
+ (map fake-block->data-decl data-blocks)
+ (list "\tDECLARE_SUBDATA_MULTIPLE (arr_"
+ decl-data-name
+ ");\n"))
+ (list "\treturn (0);\n}\n"
+ "#endif /* WANT_ONLY_CODE */\n\n")
+ ))))
+
+(define (code-blocks->array-decl decl-code-name code-blocks)
+ (append (list "static CONST struct liarc_code_S arr_"
+ decl-code-name
+ "["
+ (number->string (length code-blocks))
+ "] =\n{\n")
+ (map (lambda (code-block)
+ (string-append
+ " { \""
+ (fake-block/tag code-block)
+ "\", "
+ (number->string (fake-block/ntags code-block))
+ ", "
+ (fake-block/c-proc code-block)
+ " },\n"))
+ code-blocks)
+ (list "};\n\n")))
+
+(define (data-blocks->array-decl decl-data-name data-blocks)
+ (append (list "static CONST struct liarc_data_S arr_"
+ decl-data-name
+ "["
+ (number->string (length data-blocks))
+ "] =\n{\n")
+ (map (lambda (data-block)
+ (string-append
+ " { \""
+ (fake-block/tag data-block)
+ "\", "
+ (fake-block/d-proc data-block)
+ " },\n"))
+ data-blocks)
+ (list "};\n\n")))
\f
-(define char-set:C-char-quoted
- (char-set-union char-set:not-graphic (char-set #\\ #\')))
+(define char-set:all
+ (predicate->char-set (lambda (char) char true)))
(define char-set:C-string-quoted
- (char-set-union char-set:not-graphic (char-set #\\ #\")))
+ (char-set-union
+ ;; Not char-set:not-graphic
+ (char-set-difference char-set:all
+ (char-set-intersection char-set:graphic
+ (ascii-range->char-set 0 #x7f)))
+ (char-set #\\ #\" #\? (integer->char #xA0))))
(define char-set:C-named-chars
(char-set #\\ #\" #\Tab #\BS ;; #\' Scheme does not quote it in strings
;; #\VT #\BEL ;; Cannot depend on ANSI C
#\Linefeed #\Return #\Page))
-(define (C-quotify-string string)
- (let ((index (string-find-next-char-in-set string char-set:C-string-quoted)))
- (if (not index)
- string
- (string-append
- (substring string 0 index)
- (C-quotify-string-char (string-ref string index))
- (C-quotify-string
- (substring string (1+ index) (string-length string)))))))
-
-;; The following two routines rely on the fact that Scheme and C
-;; use the same quoting convention for the named characters when they
-;; appear in strings.
+;; This is intended for shortish character strings with the occasionall escape.
-(define (C-quotify-string-char char)
+(define (C-quotify-string string)
+ (let* ((len (string-length string))
+ ;; The maximum expansion is *4, hence we can allocate it all here
+ (temp (make-string (fix:* 4 len))))
+ (let loop ((src 0) (dst 0))
+ (if (fix:>= src len)
+ (substring temp 0 dst)
+ (let ((index (substring-find-next-char-in-set
+ string src len char-set:C-string-quoted)))
+ (if (not index)
+ (begin
+ (substring-move! string src len temp dst)
+ (loop len (fix:+ dst (fix:- len src))))
+ (let* ((i+1 (fix:+ index 1))
+ (sub (C-quotify-string-char
+ (string-ref string index)
+ (and (fix:< i+1 len)
+ (string-ref string i+1))))
+ (len* (string-length sub))
+ (off (fix:+ dst (fix:- index src))))
+ (if (> len* 4)
+ (error "C-quotify-string: Large character expansion!"
+ sub))
+ (if (not (fix:= index src))
+ (substring-move! string src index temp dst))
+ (substring-move! sub 0 len* temp off)
+ (loop i+1 (fix:+ off len*)))))))))
+
+;; The following routine relies on the fact that Scheme and C use the
+;; same quoting convention for the named characters when they appear
+;; in strings.
+
+(define (C-quotify-string-char char next)
(cond ((char-set-member? char-set:C-named-chars char)
(let ((result (write-to-string (string char))))
(substring result 1 (-1+ (string-length result)))))
((char=? char #\NUL)
- "\\0")
+ ;; Avoid ambiguities
+ (if (or (not next)
+ (not (char-set-member? char-set:numeric next)))
+ "\\0"
+ "\\000"))
+ ((char=? char #\?)
+ ;; Avoid tri-graphs
+ "\\?")
(else
(string-append
"\\"
(string-append (make-string (- 3 (string-length s)) #\0)
s)
s))))))
-
-(define (C-quotify-char char)
- (cond ((not (char-set-member? char-set:C-char-quoted char))
- (string #\' char #\'))
- ((char-set-member? char-set:C-named-chars char)
- (string-append
- "'"
- (let ((s (write-to-string (make-string 1 char))))
- (substring s 1 (-1+ (string-length s))))
- "'"))
- ((char=? char #\')
- "'\\''")
- ((char=? char #\NUL)
- "'\\0'")
+\f
+;; This is intended for binary data encoded as a character string
+;; where most of the characters are not really characters at all.
+
+(define (C-quotify-data-string/breakup string)
+ (let ((len (string-length string)))
+ (define (flush end temp res)
+ (if (= end 0)
+ res
+ (cons* "\"" (substring temp 0 end) "\t\""
+ (if (null? res)
+ res
+ (cons "\n" res)))))
+
+ (define (done end temp res)
+ (reverse! (flush end temp res)))
+
+ (define (step3 index pos temp res)
+ (let* ((i+1 (fix:+ index 1))
+ (sub (C-quotify-string-char
+ (string-ref string index)
+ (and (fix:< i+1 len)
+ (string-ref string i+1))))
+ (len* (string-length sub))
+ (next (fix:+ pos len*)))
+ (if (fix:> len* 4)
+ (error "C-quotify-string/breakup: Large character expansion!"
+ sub))
+ (if (fix:>= next 65)
+ (error "C-quotify-string/breakup: Overrun!" next))
+ (substring-move! sub 0 len* temp pos)
+ (if (fix:>= next 60)
+ (step1 i+1 0 (make-string 65) (flush next temp res))
+ (step1 i+1 next temp res))))
+
+ (define (step2 src lim dst temp res)
+ (cond ((fix:< src lim)
+ (let ((room (fix:- 60 dst))
+ (have (fix:- lim src)))
+ (cond ((fix:<= have room)
+ (substring-move! string src lim temp dst)
+ (step2 lim lim (fix:+ dst have) temp res))
+ ((fix:= room 0)
+ (step2 src lim 0 (make-string 65) (flush dst temp res)))
+ (else
+ (let ((src* (fix:+ src room))
+ (end (fix:+ dst room)))
+ (substring-move! string src src* temp dst)
+ (step2 src* lim 0 (make-string 65)
+ (flush end temp res)))))))
+ ((fix:>= lim len)
+ (done dst temp res))
+ ((fix:>= dst 60)
+ (step3 lim 0 (make-string 65) (flush dst temp res)))
+ (else
+ (step3 lim dst temp res))))
+
+ (define (step1 src dst temp res)
+ (if (fix:>= src len)
+ (done dst temp res)
+ (let ((index (substring-find-next-char-in-set
+ string src len char-set:C-string-quoted)))
+ (cond ((not index)
+ (step2 src len dst temp res))
+ ((fix:= index src)
+ (step3 index dst temp res))
+ (else
+ (step2 src index dst temp res))))))
+
+ (step1 0 0 (make-string 65) '())))
+\f
+(define (stringify-object x)
+ (cond ((string? x)
+ x)
+ ((symbol? x)
+ (%symbol->string x))
+ ((number? x)
+ (number->string x))
(else
- (string-append
- "'\\"
- (let ((s (number->string (char-code char) 8)))
- (if (< (string-length s) 3)
- (string-append (make-string (- 3 (string-length s)) #\0)
- s)
- s))
- "'"))))
+ (error "stringify: Unknown frob" x))))
+
+(define (handle-objects start-offset)
+ (if *use-stackify?*
+ (handle-objects/stackify start-offset)
+ (handle-objects/traditional start-offset)))
+
+(define (handle-objects/stackify start-offset)
+ ;; returns <next-offset decl-code decl-data xtra-procs object-prefix
+ ;; object-defines temp-vars object-block-initialization>
+ (define (iter offset table defines objects)
+ (if (null? table)
+ (values offset
+ #f ; xtra code decls
+ #f ; xtra data decls
+ '() ; xtra procs
+ '()
+ defines
+ '()
+ (reverse! objects))
+ (let ((entry (car table)))
+ (iter (+ offset 1)
+ (cdr table)
+ (cons (make-define-statement (entry-label entry) offset)
+ defines)
+ (cons (entry-value entry)
+ objects)))))
+
+ (iter start-offset
+ (reverse (table->list-of-entries objects))
+ '() ; defines
+ '() ; objects
+ ))
\f
-(define (handle-objects n)
+(define (handle-objects/traditional start-offset)
;; All the reverses produce the correct order in the output block.
;; The incoming objects are reversed
;; (environment, debugging label, purification root, etc.)
- ;; (values new-n decl-code decl-data xtra-procs object-prefix
- ;; object-defines temp-vars object-block-initialization)
+ ;; returns <next-offset decl-code decl-data xtra-procs object-prefix
+ ;; object-defines temp-vars object-block-initialization>
(fluid-let ((new-variables '())
(*subblocks* '())
(num 0))
- (define (iter n table names defines objects)
+ (define (iter offset table names defines objects)
(if (null? table)
(with-values
(lambda () (->constructors (reverse names)
(reverse objects)))
(lambda (prefix suffix)
- (values n
+ (values offset
(map fake-block->code-decl *subblocks*)
(map fake-block->data-decl *subblocks*)
(append-map fake-block->c-code *subblocks*)
new-variables
suffix)))
(let ((entry (car table)))
- (iter (1+ n)
+ (iter (+ offset 1)
(cdr table)
(cons (string-append "current_block["
(entry-label entry) "]")
names)
- (cons (make-define-statement (entry-label entry) n)
+ (cons (make-define-statement (entry-label entry) offset)
defines)
(cons (entry-value entry)
objects)))))
- (iter n (reverse (table->list-of-entries objects)) '() '() '())))
+ (iter start-offset
+ (reverse (table->list-of-entries objects))
+ '() ; names
+ '() ; defines
+ '() ; objects
+ )))
+
+(define (handle-top-level-data/traditional object)
+ (fluid-let ((new-variables '())
+ (num 0))
+ (with-values
+ (lambda () (->constructors (list "top_level_object")
+ (list object)))
+ (lambda (prefix suffix)
+ (values new-variables prefix suffix)))))
\f
+(define-integrable *execute-cache-size-in-words* 2)
+(define-integrable *variable-cache-size-in-words* 1)
+
(define (handle-free-refs-and-sets start-offset)
;; process free-uuo-links free-references free-assignments global-uuo-links
- ;; return n defines initialization
+ ;; returns <next-offset define-code data-init-code symbol-table-components>
(define (make-linkage-section-header start kind count)
- (string-append "current_block[" (number->string start)
- "L] = (MAKE_LINKER_HEADER (" kind
- ", " (number->string count) "));\n\t"))
+ (if *use-stackify?*
+ (stackify/make-linkage-header kind count)
+ (let ((kind
+ (case kind
+ ((operator-linkage-kind) "OPERATOR_LINKAGE_KIND")
+ ((global-operator-linkage-kind) "GLOBAL_OPERATOR_LINKAGE_KIND")
+ ((assignment-linkage-kind) "ASSIGNMENT_LINKAGE_KIND")
+ ((reference-linkage-kind) "REFERENCE_LINKAGE_KIND")
+ (else (error "make-linkage-section-header: unknown kind"
+ kind)))))
+ (string-append "current_block[" (number->string start)
+ "L] = (MAKE_LINKER_HEADER (" kind
+ ", " (number->string count) "));\n\t"))))
(define (insert-symbol label symbol)
(let ((name (symbol->string symbol)))
(define (process-links start links kind)
(if (null? (cdr links))
(values start 0 '() '())
- (let process ((count 0)
- (links (cdr links))
- (offset (+ start 1))
- (defines '())
- (inits '()))
- (cond ((null? links)
- (values offset
- 1
- (reverse defines)
- (cons (make-linkage-section-header start kind count)
- (reverse inits))))
- ((null? (cdr (car links)))
- (process count (cdr links) offset defines inits))
- (else
- (let ((entry (cadar links)))
- (let ((name (caar links))
- (arity (car entry))
- (symbol (cdr entry)))
- (process (1+ count)
- (cons (cons (caar links) (cddar links))
- (cdr links))
- (+ offset 2)
- (cons (make-define-statement symbol offset)
- defines)
- (cons (string-append
- (insert-symbol symbol name)
- "current_block["
- symbol
- " + 1] = ((SCHEME_OBJECT) ("
- (number->string arity) "));\n\t")
- inits)))))))))
+ (let ((use-stackify? *use-stackify?*))
+ ;; The following code implicitly assumes that
+ ;; *execute-cache-size-in-words* is 2 -- check it
+ (if (and use-stackify? (not (= *execute-cache-size-in-words* 2)))
+ (error "process-links: Size inconsistency"))
+ (let process ((count 0)
+ (links (cdr links))
+ (offset (+ start 1))
+ (defines '())
+ (inits '()))
+ (cond ((null? links)
+ (values offset
+ 1
+ (reverse defines)
+ (cons (make-linkage-section-header start kind count)
+ (reverse inits))))
+ ((null? (cdr (car links)))
+ (process count (cdr links) offset defines inits))
+ (else
+ (let ((entry (cadar links)))
+ (let ((name (caar links))
+ (arity (car entry))
+ (symbol (cdr entry)))
+ (process (1+ count)
+ (cons (cons (caar links) (cddar links))
+ (cdr links))
+ (+ offset *execute-cache-size-in-words*)
+ (cons (make-define-statement symbol offset)
+ defines)
+ (if use-stackify?
+ (cons* (stackify/make-uuo-arity arity)
+ (stackify/make-uuo-name name)
+ inits)
+ (cons (string-append
+ (insert-symbol symbol name)
+ "current_block["
+ symbol
+ " + 1] = ((SCHEME_OBJECT) ("
+ (number->string arity) "));\n\t")
+ inits)))))))))))
\f
(define (process-table start table kind)
- (define (iter n table defines inits)
- (if (null? table)
- (values n
- 1
- (reverse defines)
- (cons (make-linkage-section-header start kind
- (- n (+ start 1)))
- (reverse inits)))
- (let ((symbol (entry-label (car table))))
- (iter (1+ n)
- (cdr table)
- (cons (make-define-statement symbol n)
- defines)
- (cons (insert-symbol symbol (entry-value (car table)))
- inits)))))
+ (let ((use-stackify? *use-stackify?*))
+ ;; The following code implicitly assumes that
+ ;; *variable-cache-size-in-words* is 1 -- check it below
+
+ (define (iter offset table defines inits)
+ (if (null? table)
+ (values offset
+ 1
+ (reverse defines)
+ (cons (make-linkage-section-header start kind
+ (- offset (+ start 1)))
+ (reverse inits)))
+ (let ((symbol (entry-label (car table))))
+ (iter (+ offset *variable-cache-size-in-words*)
+ (cdr table)
+ (cons (make-define-statement symbol offset)
+ defines)
+ (if use-stackify?
+ (cons (stackify/make-var-ref-entry
+ (entry-value (car table)))
+ inits)
+ (cons (insert-symbol symbol (entry-value (car table)))
+ inits))))))
+
+ (if (and use-stackify? (not (= *variable-cache-size-in-words* 1)))
+ (error "process-links: Size inconsistency"))
- (if (null? table)
- (values start 0 '() '())
- (iter (1+ start) table '() '())))
-
- (with-values
- (lambda () (process-links start-offset free-uuo-links
- "OPERATOR_LINKAGE_KIND"))
- (lambda (offset uuos? uuodef uuoinit)
- (with-values
- (lambda ()
- (process-table offset
- (table->list-of-entries free-references)
- "REFERENCE_LINKAGE_KIND"))
- (lambda (offset refs? refdef refinit)
- (with-values
- (lambda ()
- (process-table offset
- (table->list-of-entries free-assignments)
- "ASSIGNMENT_LINKAGE_KIND"))
- (lambda (offset asss? assdef assinit)
- (with-values
- (lambda () (process-links offset global-uuo-links
- "GLOBAL_OPERATOR_LINKAGE_KIND"))
- (lambda (offset glob? globdef globinit)
- (let ((free-references-sections (+ uuos? refs? asss? glob?)))
- (values
- offset
- (append
- uuodef refdef assdef globdef
- (list
- (make-define-statement
- (special-label/free-references)
- start-offset)
- (make-define-statement
- (special-label/number-of-sections)
- free-references-sections)))
- (append uuoinit refinit assinit globinit)
- (list (cons (special-label/free-references)
- start-offset)
- (cons (special-label/number-of-sections)
- free-references-sections)))))))))))))
+ (if (null? table)
+ (values start 0 '() '())
+ (iter (+ start 1) table '() '()))))
+
+ (let*/mv (((offset uuos? uuodef uuoinit)
+ (process-links start-offset free-uuo-links
+ 'operator-linkage-kind))
+ ((offset refs? refdef refinit)
+ (process-table offset
+ (table->list-of-entries free-references)
+ 'reference-linkage-kind))
+ ((offset asss? assdef assinit)
+ (process-table offset
+ (table->list-of-entries free-assignments)
+ 'assignment-linkage-kind))
+ ((offset glob? globdef globinit)
+ (process-links offset global-uuo-links
+ 'global-operator-linkage-kind))
+ (free-references-sections (+ uuos? refs? asss? glob?)))
+
+ (values
+ offset
+ (append uuodef refdef assdef globdef
+ (list (make-define-statement (special-label/free-references)
+ start-offset)
+ (make-define-statement (special-label/number-of-sections)
+ free-references-sections)))
+ (append uuoinit refinit assinit globinit)
+ (list (cons (special-label/free-references)
+ start-offset)
+ (cons (special-label/number-of-sections)
+ free-references-sections)))))
\f
-(define (handle-labels n)
- (define (iter offset tagno labels label-defines
- label-dispatch label-block-initialization
- label-bindings)
- (if (null? labels)
- (values (- offset 1)
- tagno
- (reverse label-defines)
- (reverse label-dispatch)
- (cons (string-append
- "current_block["
- (number->string n)
- "L] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, "
- (number->string (- (- offset 1) (+ n 1)))
- "));\n\t")
- (reverse label-block-initialization))
- label-bindings)
- (let* ((label-data (car labels))
- (a-symbol (or (symbol-1 label-data)
- (symbol-2 label-data))))
- (iter (+ offset 2)
- (+ tagno 1)
- (cdr labels)
- (cons (string-append
- (make-define-statement a-symbol offset)
- (let ((other-symbol (or (symbol-2 label-data)
- (symbol-1 label-data))))
- (if (eq? other-symbol a-symbol)
- ""
- (make-define-statement other-symbol a-symbol)))
- (if (dispatch-1 label-data)
- (make-define-statement (dispatch-1 label-data)
- tagno)
- "")
- (if (dispatch-2 label-data)
- (make-define-statement (dispatch-2 label-data)
- tagno)
- ""))
- label-defines)
- (cons (string-append
- "\n\t case "
- (number->string tagno) ":\n\t\t"
- "current_block = (Rpc - " a-symbol ");\n\t\t"
- "goto "
- (symbol->string (or (label-1 label-data)
- (label-2 label-data)))
- ";\n")
- label-dispatch)
- (cons (string-append
- "WRITE_LABEL_DESCRIPTOR(¤t_block["
- a-symbol "], 0x"
- (number->string (code-word-sel label-data) 16)
- ", " a-symbol ");\n\t"
- "current_block [" a-symbol
- "] = (dispatch_base + " (number->string tagno) ");\n\t")
- label-block-initialization)
- (append
- (if (label-1 label-data)
- (list (cons (label-1 label-data) offset))
- '())
- (if (label-2 label-data)
- (list (cons (label-2 label-data) offset))
- '())
- label-bindings)))))
-
- (iter (+ 2 n) 0 (reverse! labels) '() '() '() '()))
+(define-integrable *label-sizes-in-words* 2)
+
+(define (handle-labels label-block-offset)
+ ;; returns <next-offset n-labels define-code dispatch-code
+ ;; data-init-code symbol-table-components>
+ (let ((use-stackify? *use-stackify?*))
+ (define (iter offset tagno labels label-defines
+ label-dispatch label-block-initialization
+ label-bindings)
+ (if (null? labels)
+ (values (- offset 1)
+ tagno
+ (reverse label-defines)
+ (reverse label-dispatch)
+ (if (not use-stackify?)
+ (cons (string-append
+ "current_block["
+ (number->string label-block-offset)
+ "L] = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, "
+ (number->string (- (- offset 1)
+ (+ label-block-offset 1)))
+ "));\n\t")
+ (reverse label-block-initialization))
+ (cons (stackify/make-nm-header
+ (- (- offset 1)
+ (+ label-block-offset 1)))
+ (reverse label-block-initialization)))
+ label-bindings)
+ (let* ((label-data (car labels))
+ (a-symbol (or (symbol-1 label-data)
+ (symbol-2 label-data))))
+ (iter (+ offset *label-sizes-in-words*)
+ (+ tagno 1)
+ (cdr labels)
+ (cons (string-append
+ (make-define-statement a-symbol offset)
+ (let ((other-symbol (or (symbol-2 label-data)
+ (symbol-1 label-data))))
+ (if (eq? other-symbol a-symbol)
+ ""
+ (make-define-statement other-symbol a-symbol)))
+ (if (dispatch-1 label-data)
+ (make-define-statement (dispatch-1 label-data)
+ tagno)
+ "")
+ (if (dispatch-2 label-data)
+ (make-define-statement (dispatch-2 label-data)
+ tagno)
+ ""))
+ label-defines)
+ (cons (string-append
+ "\n\t case "
+ (number->string tagno) ":\n\t\t"
+ "current_block = (Rpc - " a-symbol ");\n\t\t"
+ "goto "
+ (symbol->string (or (label-1 label-data)
+ (label-2 label-data)))
+ ";\n")
+ label-dispatch)
+ (add-label-initialization use-stackify?
+ a-symbol
+ tagno
+ offset
+ (code-word-sel label-data)
+ label-block-initialization)
+ (append
+ (if (label-1 label-data)
+ (list (cons (label-1 label-data) offset))
+ '())
+ (if (label-2 label-data)
+ (list (cons (label-2 label-data) offset))
+ '())
+ label-bindings)))))
+
+ (iter (+ label-block-offset *label-sizes-in-words*) ; offset
+ 0 ; tagno
+ (reverse! labels) ; labels
+ '() ; label-defines
+ '() ; label-dispatch
+ '() ; label-block-initialization
+ '() ; label-bindings
+ )))
\f
+(define (add-label-initialization use-stackify? a-symbol tagno
+ offset code-word rest)
+ (if use-stackify?
+ (begin
+ ;; Note: This implicitly knows that a label takes up two words.
+ (if (not (= *label-sizes-in-words* 2))
+ (error "add-label-initialization: Size inconsistency"))
+ (cons* (stackify/make-label-relative-entry tagno)
+ (stackify/make-label-descriptor code-word offset)
+ rest))
+ (cons (string-append "WRITE_LABEL_DESCRIPTOR(¤t_block["
+ a-symbol "], 0x"
+ (number->string code-word 16)
+ ", " a-symbol ");\n\t"
+ "current_block [" a-symbol
+ "] = (dispatch_base + "
+ (number->string tagno)
+ ");\n\t")
+ rest)))
+
(define-structure (fake-compiled-procedure
(constructor make-fake-compiled-procedure)
(conc-name fake-procedure/))
(block-name false read-only true)
- (label-index false read-only true))
+ (label-tag false read-only true)
+ (block false read-only true)
+ (label-value false read-only true))
(define-structure (fake-compiled-block
(constructor make-fake-compiled-block)
(conc-name fake-block/))
(name false read-only true)
+ (tag false read-only true)
(c-proc false read-only true)
(d-proc false read-only true)
(c-code false read-only true)
(index false read-only true)
- (ntags false read-only true))
+ (ntags false read-only true)
+ (proxy false read-only true))
(define fake-compiled-block-name-prefix "ccBlock")
"_" (number->string (-1+ number))))
(define (fake-block->code-decl block)
- (string-append "DECLARE_SUBCODE (\""
- (fake-block/c-proc block)
+ (string-append "\tDECLARE_SUBCODE (\""
+ (fake-block/tag block)
"\", " (number->string (fake-block/ntags block))
", NO_SUBBLOCKS, "
- (fake-block/c-proc block) ");\n\t"))
+ (fake-block/c-proc block) ");\n"))
(define (fake-block->data-decl block)
- (string-append "DECLARE_SUBDATA (\""
- (fake-block/c-proc block)
+ (string-append "\tDECLARE_SUBDATA (\""
+ (fake-block/tag block)
"\", NO_SUBBLOCKS, "
- (fake-block/d-proc block) ");\n\t"))
+ (fake-block/d-proc block) ");\n"))
(define (fake-block->c-code block)
(list (fake-block/c-code block)
- "\f\n"))
\ No newline at end of file
+ "\f\n"))
+\f
+;; Miscellaneous utilities
+
+(define (->namestring/shared path)
+ (if (and *shared-namestring*
+ (eq? (weak-car *shared-namestring*) path))
+ (weak-cdr *shared-namestring*)
+ (let* ((ns (->namestring path))
+ (wp (weak-cons path ns)))
+ (set! *shared-namestring* wp)
+ ns)))
+
+(define (string-reverse string)
+ (let* ((len (string-length string))
+ (res (make-string len)))
+ (do ((i (fix:- len 1) (fix:- i 1))
+ (j 0 (fix:+ j 1)))
+ ((fix:= j len) res)
+ (string-set! res i (string-ref string j)))))
+
+(define-integrable (guaranteed-fixnum? value)
+ (and (exact-integer? value)
+ (<= signed-fixnum/lower-limit value)
+ (< value signed-fixnum/upper-limit)))
+
+(define-integrable (guaranteed-long? value)
+ (and (exact-integer? value)
+ (<= guaranteed-long/lower-limit value)
+ (< value guaranteed-long/upper-limit)))
#| -*-Scheme-*-
-$Id: ctop.scm,v 1.15 2003/02/14 18:28:02 cph Exp $
+$Id: ctop.scm,v 1.16 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define compiled-output-extension "c")
(define compiler:invoke-c-compiler? true)
-(define compiler:c-compiler-name "cc")
+(define compiler:invoke-verbose? true)
+(define compiler:c-compiler-name #f)
(define compiler:c-compiler-switches 'UNKNOWN)
-(define compiler:c-linker-name 'UNKNOWN)
+(define compiler:c-linker-name #f)
(define compiler:c-linker-switches 'UNKNOWN)
-(define compiler:c-linker-output-extension 'UNKNOWN)
+(define compiler:c-linker-output-extension #f)
(define (compiler-file-output object pathname)
(let ((pair (vector-ref object 1)))
(write-string (cdr pair) port)))
(if compiler:invoke-c-compiler? (c-compile pathname))))
+(define (compile-data-from-file obj pathname)
+ (let ((res (stringify-data obj (merge-pathnames pathname))))
+ ;; Make output palatable to compiler-file-output
+ (vector #f (cons #f res))))
+
(define (compiler-output->procedure compiler-output environment)
(finish-c-compilation
compiler-output
;; (c-output-extension)
))))))
+(define (list->command-line l)
+ (let ((l (reverse l)))
+ (if (null? l)
+ ""
+ (let loop ((res (car l))
+ (l (cdr l)))
+ (if (null? l)
+ res
+ (loop (string-append (car l) " " res)
+ (cdr l)))))))
+\f
(define (c-compile pathname)
- ;; Some c compilers do not leave the output file in the same place.
- (with-working-directory-pathname
- (directory-pathname pathname)
- (lambda ()
- (fluid-let ((*call/cc-c-compiler* compiler:c-compiler-name)
- (*call/cc-warn?* false))
- (let ((source (enough-namestring pathname))
- (object (enough-namestring (pathname-new-type pathname "o")))
- (call/cc*
- (lambda (l)
- (let ((result (apply call/cc l)))
- #|
- ;; Some C compilers always fail
- (if (not (zero? result))
- (error "compiler: C compiler/linker failed"))
- |#
- result))))
- (if compiler:noisy?
- (begin
- (newline)
- (display ";Compiling ")
- (display source)))
- (call/cc* (append (c-compiler-switches) (list source)))
- (set! *call/cc-c-compiler* (c-linker-name))
- (if compiler:noisy?
- (begin
- (newline)
- (display ";Linking ")
- (display object)))
- (call/cc* (append (list "-o")
- (list
- (enough-namestring
- (pathname-new-type pathname
- (c-output-extension))))
- (c-linker-switches)
- (list object)))
- (delete-file object))))))
+ (let ((source (enough-namestring pathname))
+ (object (enough-namestring (pathname-new-type pathname "o")))
+ (call-program*
+ (lambda (l)
+ (let ((command-line (list->command-line l)))
+ (if compiler:invoke-verbose?
+ (begin
+ (newline)
+ (write-string ";Executing \"")
+ (write-string command-line)
+ (write-string "\"")))
+ (let ((result ((ucode-primitive system) command-line)))
+ #|
+ ;; Some C compilers always fail
+ (if (not (zero? result))
+ (error "compiler: C compiler/linker failed"))
+ |#
+ result)))))
+ (if compiler:noisy?
+ (begin
+ (newline)
+ (display ";Compiling ")
+ (display source)))
+ (call-program* (cons (c-compiler-name)
+ (append (c-compiler-switches)
+ (cons*
+ "-o"
+ object
+ (list source)))))
+ (if compiler:noisy?
+ (begin
+ (newline)
+ (display ";Linking ")
+ (display object)))
+ (call-program*
+ (cons (c-linker-name)
+ (append (list "-o")
+ (list
+ (enough-namestring
+ (pathname-new-type pathname
+ (c-output-extension))))
+ (c-linker-switches)
+ (list object))))
+ (delete-file object)))
\f
-(define (c-output-extension)
- (cond ((not (eq? compiler:c-linker-output-extension 'UNKNOWN))
- compiler:c-linker-output-extension)
- ((assoc microcode-id/operating-system-variant
- c-compiler-switch-table)
- => (lambda (place)
- (set! compiler:c-linker-output-extension (cadr place))
- (cadr place)))
- (else
- (error "c-output-extension: Unknown OS"
- microcode-id/operating-system-variant))))
-
(define c-compiler-switch-table
- `(("AIX"
+ `(
+ ;; 32-bit PowerPC MacOSX
+ ("MacOSX" ; "MacOSX-PowerPC-32"
+ "dylib"
+ ("-g" "-O2" "-fno-common" "-DPIC" "-c")
+ ("-dynamiclib" "-flat_namespace" "-undefined" "suppress")
+ "cc"
+ "ld")
+ ;; 64-bit PowerPC MacOSX
+ ("MacOSX-PowerPC-64"
+ "dylib"
+ ("-m64" "-g" "-O2" "-fno-common" "-DPIC" "-c")
+ ("-m64" "-dynamiclib" "-flat_namespace" "-undefined" "suppress")
+ "gcc-4.0"
+ "ld")
+ ;; 32-bit i386 Linux
+ ("GNU/Linux" ; "GNU/Linux-IA-32"
+ "so"
+ ("-m32" "-g" "-O2" "-fPIC" "-c")
+ ("-m32" "-shared")
+ "cc"
+ "ld")
+ ;; 64-bit x86_64 Linux
+ ("GNU/Linux-x86-64"
+ "so"
+ ("-m64" "-g" "-O2" "-fPIC" "-c")
+ ("-m64" "-shared")
+ "cc"
+ "ld")
+ ("GNU/Linux-ia64"
+ "so"
+ ("-g" "-O2" "-fPIC" "-c")
+ ("-shared")
+ "cc"
+ "ld")
+ ("NETBSD-x86-64"
+ "so"
+ ("-g" "-O2" "-fPIC" "-c")
+ ("-shared")
+ "cc"
+ "ld")
+ #|
+ ;; All the following are old stuff that probably no longer works
+ ("AIX"
"so"
("-c" "-O" "-D_AIX")
,(lambda (dir)
(->namestring (merge-pathnames dir "liarc.exp")))
(string-append "-bI:"
(->namestring (merge-pathnames dir "scheme.imp")))
- "-edload_initialize_file")))
+ "-edload_initialize_file"))
+
+ "cc"
+ "cc")
("HP-UX"
"sl"
("-c" "+z" "-O" "-Ae" "-D_HPUX")
- ("-b"))
+ ("-b")
+ "cc"
+ "ld")
("OSF"
"so"
("-c" "-std1" "-O")
- ("-shared" "-expect_unresolved" "'*'"))
+ ("-shared" "-expect_unresolved" "'*'")
+ "cc"
+ "ld")
("SunOS"
"so"
("-c" "-pic" "-O" "-Dsun4" "-D_SUNOS4" "-w")
- ())))
+ ()
+ "cc"
+ "ld")
+ |#
+ ))
+
+(define (find-switches fail-name)
+ (or (assoc (string-append microcode-id/operating-system-variant
+ "-"
+ microcode-id/machine-type)
+ c-compiler-switch-table)
+ (assoc microcode-id/operating-system-variant
+ c-compiler-switch-table)
+ (and fail-name
+ (error fail-name "Unknown OS/machine"))))
+\f
+(define (c-output-extension)
+ (or compiler:c-linker-output-extension
+ (let ((new (list-ref (find-switches 'c-output-extension) 1)))
+ (set! compiler:c-linker-output-extension new)
+ new)))
+
+(define (c-compiler-name)
+ (or compiler:c-linker-name
+ (let ((new (let ((place (find-switches #f)))
+ (if place
+ (list-ref place 4)
+ "cc"))))
+ (set! compiler:c-linker-name new)
+ new)))
(define (c-compiler-switches)
(if (not (eq? compiler:c-compiler-switches 'UNKNOWN))
compiler:c-compiler-switches
- (let ((place (assoc microcode-id/operating-system-variant
- c-compiler-switch-table))
+ (let ((place (find-switches 'c-compiler-switches))
(dir (system-library-directory-pathname "include")))
- (cond ((not place)
- (error 'c-compiler-switches "Unknown OS"
- microcode-id/operating-system-variant))
- ((not dir)
- (error 'c-compiler-switches
- "Cannot find \"include\" directory"))
- (else
- (let ((result
- (append
- (caddr place)
- (list
- (string-append
- "-I"
- (->namestring
- (directory-pathname-as-file dir)))))))
- (set! compiler:c-compiler-switches result)
- result))))))
-\f
+ (if (not dir)
+ (error 'c-compiler-switches
+ "Cannot find \"include\" directory")
+ (let ((result
+ (append
+ (list-ref place 2)
+ (list
+ (string-append
+ "-I"
+ (->namestring
+ (directory-pathname-as-file dir)))))))
+ (set! compiler:c-compiler-switches result)
+ result)))))
+
(define (c-linker-name)
- (if (not (eq? compiler:c-linker-name 'UNKNOWN))
- compiler:c-linker-name
- (let ((new (if (string=? "AIX" microcode-id/operating-system-variant)
- "cc"
- "ld")))
+ (or compiler:c-linker-name
+ (let ((new (let ((place (find-switches #f)))
+ (if place
+ (list-ref place 5)
+ "ld"))))
(set! compiler:c-linker-name new)
new)))
(define (c-linker-switches)
- (cond ((not (eq? compiler:c-linker-switches 'UNKNOWN))
- compiler:c-linker-switches)
- ((assoc microcode-id/operating-system-variant c-compiler-switch-table)
- => (lambda (place)
- (let ((switches
- (let ((switches (cadddr place)))
- (if (not (scode/procedure? switches))
- switches
- (let ((dir (system-library-directory-pathname
- "include")))
- (if (not dir)
- (error 'c-linker-switches
- "Cannot find \"include\" directory"))
- (switches dir))))))
- (set! compiler:c-linker-switches switches)
- switches)))
- (else
- (error 'c-linker-switches "Unknown OS"
- microcode-id/operating-system-variant))))
+ (if (not (eq? compiler:c-linker-switches 'UNKNOWN))
+ compiler:c-linker-switches
+ (let* ((place (find-switches 'c-linker-switches))
+ (switches
+ (let ((switches (list-ref place 3)))
+ (if (not (procedure? switches))
+ switches
+ (let ((dir (system-library-directory-pathname
+ "include")))
+ (if (not dir)
+ (error 'c-linker-switches
+ "Cannot find \"include\" directory"))
+ (switches dir))))))
+ (set! compiler:c-linker-switches switches)
+ switches)))
(define (recursive-compilation-results)
(sort *recursive-compilation-results*
;; Global variables for assembler and linker
(define *recursive-compilation-results*)
+(define *shared-namestring*)
;; First set: phase/rtl-generation
;; Last used: phase/link
(define *ntags*)
(define *labels*)
(define *code*)
+(define *proxy*)
;; First set: phase/output-generation
(define *result*)
,@some-lap))
\f
(define (bind-assembler&linker-top-level-variables thunk)
- (fluid-let ((*recursive-compilation-results* '()))
+ (fluid-let ((*recursive-compilation-results* '())
+ (*shared-namestring* #f))
(thunk)))
(define (bind-assembler&linker-variables thunk)
(*C-data-name*)
(*ntags*)
(*labels*)
- (*code*))
+ (*code*)
+ (*proxy*))
(thunk)))
(define (assembler&linker-reset!)
(set! *ntags*)
(set! *labels*)
(set! *code*)
+ (set! *proxy*)
unspecific)
(define (initialize-back-end!)
(cons "foo.bar" *recursive-compilation-number*)))
(else
pathname))))
- (lambda (code-name data-name ntags labels code)
+ (lambda (code-name data-name ntags labels code proxy)
(set! *C-code-name* code-name)
(set! *C-data-name* data-name)
(set! *ntags* ntags)
(set! *labels* labels)
(set! *code* code)
+ (set! *proxy* proxy)
unspecific)))))
(define (phase/output-generation)
(translate-label (vector-ref linking-info index))))
(index *recursive-compilation-number*)
(name (fake-compiled-block-name index)))
- (cons (make-fake-compiled-procedure
- name
- (translate-label *entry-label*))
- (vector
+ (let ((fcb
(make-fake-compiled-block name
- *C-code-name*
- *C-data-name*
- *code*
+ *C-code-name* ; tag
+ *C-code-name* ; c-proc
+ *C-data-name* ; d-proc
+ *code* ; c-code
index
- *ntags*)
- (translate-symbol 0)
- (translate-symbol 1)
- (translate-symbol 2))))
+ *ntags*
+ *proxy*))
+ (lab (translate-label *entry-label*)))
+ (cons (make-fake-compiled-procedure name lab fcb lab)
+ (vector
+ fcb
+ (translate-symbol 0)
+ (translate-symbol 1)
+ (translate-symbol 2)))))
(cons *C-code-name*
*code*)))
(set! *entry-label*)
(set! *ic-procedure-headers*)
(set! *code*)
+ (set! *proxy*)
unspecific)))
\f
(define (phase/info-generation-2 labels pathname)
(case char
((#\?) #\P)
((#\!) #\B)
- (else #\_)))))))))
\ No newline at end of file
+ (else #\_)))))))))
#| -*-Scheme-*-
-$Id: decls.scm,v 1.9 2003/03/10 20:51:49 cph Exp $
+$Id: decls.scm,v 1.10 2006/09/16 11:19:09 gjr Exp $
-Copyright 1993,2001,2003 Massachusetts Institute of Technology
+Copyright 1993,2001,2003,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(and binary (< source binary) binary))))
(set-source-node/modification-time! node modification-time)
(if (not modification-time)
- (begin (write-string "\nSource file newer than binary: ")
- (write (source-node/filename node))))))
+ (begin
+ (fresh-line)
+ (write-string "Source file newer than binary: ")
+ (write (source-node/filename node))
+ (newline)))))
source-nodes)
(if compiler:enable-integration-declarations?
(begin
(> time* time)))))
(if newer?
(begin
- (write-string "\nBinary file ")
+ (fresh-line)
+ (write-string "Binary file ")
(write (source-node/filename node))
(write-string " newer than dependency ")
- (write (source-node/filename node*))))
+ (write (source-node/filename node*))
+ (newline)))
newer?))))
(set-source-node/modification-time! node #f))))
source-nodes)
(for-each (lambda (node*)
(if (source-node/modification-time node*)
(begin
- (write-string "\nBinary file ")
+ (fresh-line)
+ (write-string "Binary file ")
(write (source-node/filename node*))
(write-string " depends on ")
- (write (source-node/filename node))))
+ (write (source-node/filename node))
+ (newline)))
(set-source-node/modification-time! node* #f))
(source-node/forward-closure node))))
source-nodes)))
(pathname-delete!
(pathname-new-type (source-node/pathname node) "ext"))))
source-nodes/by-rank)
- (write-string "\n\nBegin pass 1:")
+ (fresh-line)
+ (newline)
+ (write-string "Begin pass 1:")
+ (newline)
(for-each (lambda (node)
(if (not (source-node/modification-time node))
(source-node/syntax! node)))
(and (not (source-node/modification-time node))
(source-node/circular? node))))
(begin
- (write-string "\n\nBegin pass 2:")
+ (fresh-line)
+ (newline)
+ (write-string "Begin pass 2:")
+ (newline)
(for-each (lambda (node)
(if (not (source-node/modification-time node))
(if (source-node/circular? node)
(define (pathname-touch! pathname)
(if (file-exists? pathname)
(begin
- (write-string "\nTouch file: ")
+ (fresh-line)
+ (write-string "Touch file: ")
(write (enough-namestring pathname))
+ (newline)
(file-touch pathname))))
(define (pathname-delete! pathname)
(if (file-exists? pathname)
(begin
- (write-string "\nDelete file: ")
+ (fresh-line)
+ (write-string "Delete file: ")
(write (enough-namestring pathname))
+ (newline)
(delete-file pathname))))
(define (sc filename)
filenames))))
(file-dependency/syntax/join
(append (filename/append "base"
- "toplev" ; "asstop" "crstop"
+ "toplev"
"blocks" "cfg1" "cfg2" "cfg3" "constr"
"contin" "ctypes" "debug" "enumer"
"infnew" "lvalue" "object" "pmerly" "proced"
(filename/append "back"
"insseq" "lapgn1" "lapgn2" "linear" "regmap")
(filename/append "machines/C"
- "cout" "ctop" "machin" "rulrew" "rgspcm")
+ "cout" "ctop" "traditional" "stackify" "stackops"
+ "machin" "rulrew" "rgspcm")
(filename/append "fggen"
"declar" "fggen" "canon")
(filename/append "fgopt"
(file-dependency/syntax/join
(filename/append "machines/C"
"lapgen"
- "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo" "cout")
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+ "cout" "traditional" "stackify" "stackops")
(->environment '(COMPILER LAP-SYNTAXER)))))
\f
;;;; Integration Dependencies
(define (initialize/integration-dependencies!)
+ #|
(define (add-declaration! declaration filenames)
(for-each (lambda (filenames)
(let ((node (filename->source-node filenames)))
(cons declaration
(source-node/declarations node)))))
filenames))
+ |#
(let* ((front-end-base
(filename/append "base"
(filename/append "machines/C" "machin"))
(rtl-base
(filename/append "rtlbase"
- "regset" "rgraph" "rtlcfg" "rtlobj"
- "rtlreg" "rtlty1" "rtlty2"))
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
(cse-base
(filename/append "rtlopt"
"rcse1" "rcseht" "rcserq" "rcsesr"))
(filename/append "back" "lapgn1" "lapgn2")
(filename/append "machines/C"
"rules1" "rules2" "rules3" "rules4"
- "rulfix" "rulflo" "cout"
+ "rulfix" "rulflo"
+ "cout" "traditional" "stackify" "stackops"
))))
(define (file-dependency/integration/join filenames dependencies)
(define-integration-dependencies "machines/C" "machin" "rtlbase"
"rtlreg" "rtlty1" "rtlty2")
- (define-integration-dependencies "rtlbase" "regset" "base")
(define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
(define-integration-dependencies "rtlbase" "rgraph" "machines/C"
"machin")
(define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
(define-integration-dependencies "rtlbase" "rtlcon" "machines/C"
"machin")
+ (file-dependency/integration/join (filename/append "rtlbase" "rtlcon")
+ rtl-base)
(define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
"rtlreg" "rtlty1")
(define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
lapgen-base
lapgen-body
(filename/append "back" "linear"))))
+ #|
(add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ |#
(file-dependency/integration/join dependents instruction-base))
(file-dependency/integration/join (append lapgen-base lapgen-body)
(define-integration-dependencies "back" "lapgn1" "base"
"cfg1" "cfg2" "utils")
(define-integration-dependencies "back" "lapgn1" "rtlbase"
- "regset" "rgraph" "rtlcfg")
+ "rgraph" "rtlcfg")
(define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
(define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
(define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
#| -*-Scheme-*-
-$Id: lapgen.scm,v 1.17 2004/07/01 01:19:57 cph Exp $
+$Id: lapgen.scm,v 1.18 2006/09/16 11:19:09 gjr Exp $
-Copyright 1993,1998,2001,2002,2004 Massachusetts Institute of Technology
+Copyright 1993,1998,2001,2002,2004,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
'REGISTER->HOME-TRANSFER one two))
(define (lap:make-label-statement label)
- (LAP "\n" ,label ":\n\t" ))
+ (LAP "\nDEFLABEL(" ,label ");\n\t" ))
(define (lap:make-unconditional-branch label)
(LAP "goto " ,label ";\n\t"))
#| -*-Scheme-*-
-$Id: machin.scm,v 1.10 2003/02/14 18:28:02 cph Exp $
+$Id: machin.scm,v 1.11 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
;; We expect a C long to be at least 32 bits wide,
;; but not necessarily two's complement.
+;; Tags won't be wider than 6 bits
(define-integrable min-long-width 32)
-(define-integrable max-tag-width 8)
+(define-integrable max-tag-width 6)
(define-integrable guaranteed-long/upper-limit
(expt 2 (-1+ min-long-width)))
(define signed-fixnum/lower-limit
(- signed-fixnum/upper-limit))
+(define-integrable unsigned-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit))
+
(define-integrable (stack->memory-offset offset) offset)
(define-integrable ic-block-first-parameter-offset 2)
(define-integrable execute-cache-size 2) ; Long words per UUO link slot
;;; Fixed-use registers due to architecture or OS calling conventions.
-(define machine-register-value-class
- (let ((special-registers
- `((,regnum:stack-pointer . ,value-class=address)
- (,regnum:regs . ,value-class=unboxed)
- (,regnum:free . ,value-class=address)
- (,regnum:dynamic-link . ,value-class=address)
- (,regnum:value . ,value-class=object))))
-
- (lambda (register)
- (let ((lookup (assv register special-registers)))
- (cond
- ((not (null? lookup)) (cdr lookup))
- (else (error "illegal machine register" register)))))))
+(define (machine-register-value-class register)
+ (cond ((or (= register regnum:regs)
+ (= register regnum:stack-pointer)
+ (= register regnum:free)
+ (= register regnum:dynamic-link))
+ value-class=address)
+ ((= register regnum:value)
+ value-class=object)
+ (else
+ (error "illegal machine register" register))))
(define-integrable (machine-register-known-value register)
register ;ignore
;;;; Interpreter Registers
(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/int-mask-offset 1)
(define-integrable register-block/value-offset 2)
(define-integrable register-block/environment-offset 3)
(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
(case rtl-register
((MEMORY-TOP)
register-block/memtop-offset)
+ ((INT-MASK)
+ register-block/int-mask-offset)
((STACK-GUARD)
register-block/stack-guard-offset)
((ENVIRONMENT)
#| -*-Scheme-*-
-$Id: make.scm,v 1.5 2003/02/14 18:28:02 cph Exp $
+$Id: make.scm,v 1.6 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992, 1999 Massachusetts Institute of Technology
+Copyright (c) 1992, 1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(begin
(declare-shared-library "sf+compiler" (lambda () true))
- (let ((value ((load "base/make") "C")))
+ (let ((value ((load "base/make")
+ (string-append "C/" microcode-id/machine-type))))
(set! (access compiler:compress-top-level? (->environment '(compiler)))
true)
+ (set! (access compiler:compile-data-files-as-expressions?
+ (->environment '(compiler top-level)))
+ false)
+ (set! (access compiler:fggen-unmap-reference-traps-early?
+ (->environment '(compiler fg-generator)))
+ false)
value))
\ No newline at end of file
+++ /dev/null
-#!/bin/csh -f
-
-cd $jw/microcode
-make -k -f xmakefile scheme
#| -*-Scheme-*-
-$Id: rules2.scm,v 1.5 2003/02/14 18:28:02 cph Exp $
+$Id: rules2.scm,v 1.6 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992, 1999 Massachusetts Institute of Technology
+Copyright (c) 1992, 1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(LAP)))
(define-rule predicate
- ;; Branch if virtual register contains the specified type number
+ ;; Branch if virtual register contains a legal index fixnum
(PRED-1-ARG INDEX-FIXNUM?
(REGISTER (? source)))
(let ((source (standard-source! source 'ULONG)))
(set-current-branches!
(lambda (if-true-label)
- (LAP "if (INDEX_FIXNUM_P" ,source ")\n\t goto " ,if-true-label
+ (LAP "if (INDEX_FIXNUM_P (" ,source "))\n\t goto " ,if-true-label
";\n\t"))
(lambda (if-false-label)
- (LAP "if (!(INDEX_FIXNUM_P" ,source "))\n\t goto " ,if-false-label
+ (LAP "if (!(INDEX_FIXNUM_P (" ,source ")))\n\t goto " ,if-false-label
";\n\t")))
(LAP)))
#| -*-Scheme-*-
-$Id: rulrew.scm,v 1.6 2003/02/14 18:28:02 cph Exp $
+$Id: rulrew.scm,v 1.7 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define (rtl:constant-fixnum? expression)
(and (rtl:constant? expression)
- (fix:fixnum? (rtl:constant-value expression))))
+ (signed-fixnum? (rtl:constant-value expression))))
\f
(define-rule rewriting
(FLOAT-OFFSET (REGISTER (? base register-known-value))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: stackify.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; C-output object pseudo-assembler that outputs a stack-based byte code
+;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define debug? #f)
+
+(define *record/1* #f)
+
+(define (write-debug-record/1 depth prog)
+ (set! *record/1*
+ `(stack-depth ,depth
+ pc
+ ,(string-list/length (stackify-program/opcodes prog))
+ strtab-ptr
+ ,(string-list/length (stackify-program/strtab prog))))
+ unspecific)
+
+(define (write-debug-record/2 op)
+ (write (append `(opcode ,(vector-ref *stackify/opcode-name* op)) *record/1*))
+ (newline)
+ (set! *record/1* #f)
+ unspecific)
+
+
+(define *stackify/table*)
+(define *stackify/tag-base*)
+(define *stackify/tag-next*)
+
+(define-integrable (recnum? obj)
+ (object-type? (object-type 3+4i) obj))
+
+(define-integrable (ratnum? obj)
+ (object-type? (object-type 3/4) obj))
+
+(define-integrable (constant? obj)
+ (object-type? (object-type #t) obj))
+
+(define-integrable (fix:max x y)
+ (if (fix:< x y)
+ y
+ x))
+\f
+;; This version uses an eq hash table
+
+(define-integrable (stackify/make-table)
+ (make-eq-hash-table))
+
+(define-integrable (stackify/table/lookup key)
+ (hash-table/get *stackify/table* key #f))
+
+(define-integrable (stackify/table/associate! key val)
+ (hash-table/put! *stackify/table* key val))
+
+;; An value in the table looks like
+;;
+;; #(max-count build-count recursive recursing?)
+;;
+;; where max-count is the number of times it is encountered in the walk
+;; and build-count is the number of times it has been built
+;; During walk, build-count remains at 0 while max-count increments
+;; During build, max-count remains constant while build-count increments
+
+(define (stackify/count/increment! obj)
+ (let ((info (stackify/table/lookup obj)))
+ (if (not info)
+ (let ((new (vector 1 0 #f #t)))
+ (stackify/table/associate! obj new)
+ new)
+ (let ((new (fix:+ (vector-ref info 0) 1)))
+ (if (vector-ref info 3) ;if recursing?, recursive
+ (vector-set! info 2 #t))
+ (vector-set! info 0 new)
+ info))))
+
+(define (stackify/count/decrement! obj)
+ (let ((info (stackify/table/lookup obj)))
+ (cond ((not info)
+ (error "stackify/count/decrement!: Unknown object" obj))
+ ((fix:= (vector-ref info 1) (vector-ref info 0))
+ (error "stackify/count/decrement!: Seen too many times" obj))
+ (else
+ (let ((new (fix:+ (vector-ref info 1) 1)))
+ (vector-set! info 1 new)
+ info)))))
+
+(define (stackify/shared? obj)
+ (let ((info (stackify/table/lookup obj)))
+ (and info
+ (not (fix:= (vector-ref info 0) 1))
+ (not (fix:= (vector-ref info 1) (vector-ref info 0))))))
+\f
+(define (walk/trivial? obj)
+ (or (boolean? obj)
+ (null? obj)
+ (reference-trap? obj)
+ (constant? obj)
+ (char? obj)
+ (guaranteed-fixnum? obj)
+ (stackify-escape? obj)))
+
+;; Note: complex and ratnum are compound: Build components and then
+;; aggregate
+
+(define (walk/simple? obj)
+ (or (exact-integer? obj)
+ (flo:flonum? obj)
+ (symbol? obj)
+ (string? obj)
+ (bit-string? obj)
+ (primitive-procedure? obj)
+ ;; The runtime system needs the following
+ (interpreter-return-address? obj)))
+
+(define (walk/vector obj)
+ (let ((len (vector-length obj)))
+ (let loop ((i len))
+ (and (fix:> i 0)
+ (let ((next-i (fix:- i 1)))
+ (walk (vector-ref obj next-i))
+ (loop next-i))))))
+
+(define (walk/compound obj)
+ (cond ((walk/simple? obj)
+ unspecific)
+ ((number? obj)
+ (cond ((recnum? obj)
+ (walk (real-part obj))
+ (walk (imag-part obj)))
+ ((ratnum? obj)
+ (walk (numerator obj))
+ (walk (denominator obj)))
+ (else
+ (error "walk: Unknown kind of number"
+ obj))))
+ ((fake-compiled-block? obj)
+ ;; For now, fake compiled blocks are almost simple, as they
+ ;; are built separately. We just need to remember them
+ ;; in walk order
+ (set! *subblocks* (cons obj *subblocks*))
+ (walk/vector (fake-block/proxy obj)))
+ ((pair? obj)
+ (walk (car obj))
+ (walk (cdr obj)))
+ ((%record? obj)
+ (let ((len (%record-length obj)))
+ (let loop ((i len))
+ (and (fix:> i 0)
+ (let ((next-i (fix:- i 1)))
+ (walk (%record-ref obj next-i))
+ (loop next-i))))))
+ ((vector? obj)
+ (walk/vector obj))
+ (else
+ (error "walk/compound: Unknown kind of object" obj))))
+
+(define (walk obj)
+ (cond ((walk/trivial? obj) unspecific)
+ ((fake-compiled-procedure? obj)
+ ;; Pseudo-trivial: Walk the compiled code block instead
+ ;; so that it is encountered in walk order
+ (walk (fake-procedure/block obj)))
+ (else
+ (let ((info (stackify/count/increment! obj)))
+ (and (fix:= (vector-ref info 0) 1)
+ (begin
+ (walk/compound obj)
+ (vector-set! info 3 #f)
+ unspecific))))))
+\f
+(define (regmap/empty)
+ (list 'tag))
+
+(define (regmap/lookup regmap obj)
+ (let ((place (assq obj (cdr regmap))))
+ (and place
+ (cdr place))))
+
+;; These versions update regmap in place
+
+(define (regmap/allocate regmap obj)
+ ;; Returns <regmap place>
+ (let ((place (assq obj (cdr regmap))))
+ (if place
+ (error "regmap/allocate: Doubly-allocated" regmap obj))
+ (let ((place (assq #f (cdr regmap))))
+ (cond (place
+ (set-car! place obj)
+ (values regmap (cdr place)))
+ ((null? (cdr regmap))
+ (set-cdr! regmap (list (cons obj 0)))
+ (values regmap 0))
+ (else
+ (let* ((last (cadr regmap))
+ (idx (fix:+ (cdr last) 1)))
+ (set-cdr! regmap (cons (cons obj idx) (cdr regmap)))
+ (values regmap idx)))))))
+
+(define (regmap/forget regmap obj)
+ (let ((place (assq obj (cdr regmap))))
+ (if (not place)
+ (error "regmap/forget: Not present" regmap obj))
+ (set-car! place #f)
+ regmap))
+
+(define (regmap/max-entries regmap)
+ (length (cdr regmap)))
+\f
+;; Byte-coded back end
+
+(define *string-list/quantum* 512)
+
+(define-structure (string-list
+ (constructor string-list/make ())
+ (conc-name string-list/))
+ (length 0)
+ (pointer 0)
+ (current (make-string *string-list/quantum*))
+ (stack '()))
+
+(define (string-list/add-byte! sl byte)
+ (let ((ptr (string-list/pointer sl))
+ (current (string-list/current sl))
+ (length (string-list/length sl)))
+ (if (fix:< ptr (string-length current))
+ (begin
+ (vector-8b-set! current ptr byte)
+ (set-string-list/pointer! sl (fix:+ ptr 1))
+ (set-string-list/length! sl (fix:+ length 1))
+ sl)
+ (let ((new (make-string *string-list/quantum*)))
+ (set-string-list/stack! sl
+ (cons (cons ptr current)
+ (string-list/stack sl)))
+ (set-string-list/current! sl new)
+ (set-string-list/pointer! sl 0)
+ (string-list/add-byte! sl byte)))))
+
+(define (%string-list/add-string! sl str)
+ (let ((ptr (string-list/pointer sl))
+ (current (string-list/current sl))
+ (length (string-list/length sl))
+ (str-len (string-length str)))
+ (let ((new-ptr (fix:+ ptr str-len)))
+ (cond ((not (fix:> new-ptr (string-length current)))
+ (substring-move! str 0 str-len current ptr)
+ (set-string-list/pointer! sl new-ptr)
+ (set-string-list/length! sl (fix:+ length str-len))
+ sl)
+ ((fix:= ptr 0)
+ (set-string-list/stack! sl
+ (cons (cons str-len str)
+ (string-list/stack sl)))
+ (set-string-list/length! sl (fix:+ length str-len))
+ sl)
+ (else
+ (let ((new (make-string *string-list/quantum*)))
+ (set-string-list/stack! sl
+ (cons (cons ptr current)
+ (string-list/stack sl)))
+ (set-string-list/current! sl new)
+ (set-string-list/pointer! sl 0)
+ (if (fix:< (fix:* 4 str-len) (fix:* 3 *string-list/quantum*))
+ (%string-list/add-string! sl str)
+ (begin
+ (set-string-list/stack! sl
+ (cons (cons str-len str)
+ (string-list/stack sl)))
+ (set-string-list/length! sl (fix:+ length str-len))
+ sl))))))))
+\f
+;; We add 1 before encoding the value so that there
+;; are no null characters in the encoding.
+;; The decoder subtracts one from the decoded value.
+
+(define (encode-nat nat)
+ ;; result: <n-digits digits>
+ (let loop ((length 0) (nat (+ nat 1)) (digits '()))
+ (if (< nat 128)
+ (values (fix:+ length 1) (reverse! (cons nat digits)))
+ (loop (fix:+ length 1)
+ (quotient nat 128)
+ (cons (fix:+ 128 (remainder nat 128))
+ digits)))))
+
+(define (string-list/add-nat! sl nat)
+ (call-with-values
+ (lambda ()
+ (encode-nat nat))
+ (lambda (n-digits digits)
+ n-digits ; unused
+ (let loop ((digits digits)
+ (sl sl))
+ (if (null? digits)
+ sl
+ (loop (cdr digits)
+ (string-list/add-byte! sl (car digits))))))))
+
+(define (string-list/add-string! sl str)
+ (string-list/add-nat! sl (string-length str))
+ (%string-list/add-string! sl str))
+
+(define (string-list/write! result offset sl)
+ (let loop ((stack (reverse (cons (cons (string-list/pointer sl)
+ (string-list/current sl))
+ (string-list/stack sl))))
+ (offset offset))
+ (if (null? stack)
+ offset
+ (let ((comp (cdar stack))
+ (complen (caar stack)))
+ (substring-move! comp 0 complen result offset)
+ (loop (cdr stack)
+ (fix:+ offset complen))))))
+\f
+;; A program is a pair of string lists
+;; The first string list is the opcode string list
+;; The second string list is the string table
+
+(define-structure (stackify-program
+ (constructor stackify-program/make ())
+ (conc-name stackify-program/))
+ (opcodes (string-list/make))
+ (strtab (string-list/make)))
+
+(define (stackify/empty-program)
+ (stackify-program/make))
+
+(define (stackify/finalize-program prog sdepth rsize)
+ (let ((header (string-list/make))
+ (opcodes (stackify-program/opcodes prog))
+ (strtab (stackify-program/strtab prog)))
+ (string-list/add-nat! header sdepth)
+ (string-list/add-nat! header rsize)
+ (let ((oplen (string-list/length opcodes)))
+ (string-list/add-nat! header oplen)
+ (let* ((headlen (string-list/length header))
+ (preflen (fix:+ headlen oplen))
+ (totlen (fix:+ preflen (string-list/length strtab)))
+ (bytes (make-string totlen)))
+ (let ((off (string-list/write! bytes 0 header)))
+ (if (not (fix:= off headlen))
+ (error "stackify/finalize-program Counter inconsistency 1")))
+ (let ((off (string-list/write! bytes headlen opcodes)))
+ (if (not (fix:= off preflen))
+ (error "stackify/finalize-program Counter inconsistency 2")))
+ (let ((off (string-list/write! bytes preflen strtab)))
+ (if (not (fix:= off totlen))
+ (error "stackify/finalize-program Counter inconsistency 3")))
+ bytes))))
+\f
+(define-integrable (build/push-opcode! opcode prog)
+ (if debug?
+ (write-debug-record/2 opcode))
+ (string-list/add-byte! (stackify-program/opcodes prog) opcode)
+ prog)
+
+(define (build/single-opcode opcode prog)
+ (build/push-opcode! opcode prog))
+
+(define (build/natural opcode nat prog)
+ (string-list/add-nat! (stackify-program/strtab prog) nat)
+ (build/push-opcode! opcode prog))
+
+(define (build/push-nat nat prog)
+ (string-list/add-nat! (stackify-program/strtab prog) nat)
+ prog)
+
+(define (build/string opcode str prog)
+ (string-list/add-string! (stackify-program/strtab prog) str)
+ (build/push-opcode! opcode prog))
+
+;; Push a trivial non-pointer object
+
+(define (build/trivial obj prog)
+ (cond ((eq? obj #f)
+ (build/single-opcode stackify-opcode/push-false prog))
+ ((eq? obj #t)
+ (build/single-opcode stackify-opcode/push-true prog))
+ ((eq? obj '())
+ (build/single-opcode stackify-opcode/push-nil prog))
+ ((reference-trap? obj)
+ (if (not (unassigned-reference-trap? obj))
+ (error "build/trivial: Can't build reference trap" obj))
+ (build/single-opcode stackify-opcode/push-unassigned prog))
+ ((constant? obj)
+ (build/natural stackify-opcode/push-constant
+ (object-datum obj)
+ prog))
+ ((char? obj)
+ (build/natural stackify-opcode/push-char
+ (char-code obj)
+ (build/push-nat (char-bits obj) prog)))
+ ((stackify-escape? obj)
+ (build/escape obj prog))
+ ((not (guaranteed-fixnum? obj))
+ (error "build/trivial: Not trivial" obj))
+ ((fix:< obj 0)
+ (if (fix:= obj -1)
+ (build/single-opcode stackify-opcode/push--1 prog)
+ (build/natural stackify-opcode/push--fixnum
+ (fix:- 0 obj)
+ prog)))
+ ((fix:< obj (vector-length stackify/fast-fixnum-opcodes))
+ (build/single-opcode (vector-ref stackify/fast-fixnum-opcodes obj)
+ prog))
+ (else
+ (build/natural stackify-opcode/push-+fixnum
+ obj
+ prog))))
+\f
+(define (build/escape obj prog)
+ (let ((kind (stackify-escape/kind obj))
+ (contents (stackify-escape/contents obj)))
+ (case kind
+ ((arity)
+ (build/natural stackify-opcode/push-ulong
+ contents
+ prog))
+ ((label-descriptor)
+ (let ((code-word (car contents))
+ (offset (cdr contents)))
+ (build/natural stackify-opcode/push-label-descriptor
+ code-word
+ (build/push-nat offset prog))))
+ ((label-relative-entry)
+ (build/natural stackify-opcode/push-label-entry
+ (+ contents *stackify/tag-base*)
+ prog))
+ ((nm-header)
+ (build/natural stackify-opcode/push-nm-header
+ contents
+ prog))
+ ((operator-linkage-kind)
+ (build/natural stackify-opcode/push-linkage-header-operator
+ contents
+ prog))
+ ((global-operator-linkage-kind)
+ (build/natural stackify-opcode/push-linkage-header-global
+ contents
+ prog))
+ ((assignment-linkage-kind)
+ (build/natural stackify-opcode/push-linkage-header-assignment
+ contents
+ prog))
+ ((reference-linkage-kind)
+ (build/natural stackify-opcode/push-linkage-header-reference
+ contents
+ prog))
+ (else
+ (error "build/escape: Unknown kind" kind)))))
+
+;; Pop two elements off the stack, make a pair of the type of obj
+
+(define (build/simple-pair obj prog)
+ (build/single-opcode
+ (cond ((recnum? obj)
+ stackify-opcode/push-cons-recnum)
+ ((ratnum? obj)
+ stackify-opcode/push-cons-ratnum)
+ (else
+ (error "build/simple-pair: Unexpected object" obj)))
+ prog))
+\f
+;; Push a simple pointer object
+
+(define (build/simple obj prog)
+ (cond ((string? obj)
+ (build/string stackify-opcode/push-string obj prog))
+ ((symbol? obj)
+ (build/string
+ (if (uninterned-symbol? obj)
+ stackify-opcode/push-uninterned-symbol
+ stackify-opcode/push-symbol)
+ (symbol-name obj)
+ prog))
+ ((bit-string? obj)
+ (build/string stackify-opcode/push-bit-string
+ (reverse-string
+ (number->string
+ (bit-string->unsigned-integer obj)
+ 16))
+ (build/push-nat (bit-string-length obj) prog)))
+ ((primitive-procedure? obj)
+ (let ((arity (primitive-procedure-arity obj))
+ (name (symbol-name (primitive-procedure-name obj))))
+ (cond ((fix:< arity 0)
+ (build/string stackify-opcode/push-primitive-lexpr
+ name
+ prog))
+ ((fix:< arity (vector-length stackify/fast-primitive-opcodes))
+ (build/string
+ (vector-ref stackify/fast-primitive-opcodes arity)
+ name
+ prog))
+ (else
+ (build/string
+ stackify-opcode/push-primitive
+ name
+ (build/push-nat arity prog))))))
+ ((exact-integer? obj)
+ (let ((val (if (< obj 0) (- 0 obj) obj))
+ (op (if (< obj 0)
+ stackify-opcode/push--integer
+ stackify-opcode/push-+integer)))
+ (build/string op
+ (number->string val 16)
+ prog)))
+ ((flo:flonum? obj)
+ (build/string stackify-opcode/push-flonum
+ (number->string obj)
+ prog))
+ ;; The runtime system needs the following
+ ((interpreter-return-address? obj)
+ (build/natural
+ stackify-opcode/push-return-code
+ (object-datum obj)
+ prog))
+ (else
+ (error "build/simple: Not simple" obj))))
+\f
+(define (build/fast index opcodes generic prog)
+ (if (and (fix:< index (vector-length opcodes))
+ (vector-ref opcodes index))
+ (build/single-opcode (vector-ref opcodes index)
+ prog)
+ (build/natural generic
+ index
+ prog)))
+
+(define (build/lookup obj prog regmap)
+ (let ((place (regmap/lookup regmap obj)))
+ (if (not place)
+ (error "build/lookup: Can't find" obj))
+ (build/fast place
+ stackify/fast-lookup-opcodes
+ stackify-opcode/push-lookup
+ prog)))
+
+;; Store top of stack to a regmap location, don't pop
+
+(define (build/store place prog)
+ (build/fast place
+ stackify/fast-store-opcodes
+ stackify-opcode/store
+ prog))
+
+;; Pop N+1 elements off the stack and cons* them, push result
+;; TOS is last cdr
+
+(define (build/cons* n prog)
+ (build/fast n
+ stackify/fast-cons*-opcodes
+ stackify-opcode/push-cons*
+ prog))
+
+;; Build '(#f #f)
+
+(define (build/empty-cons prog)
+ (build/single-opcode stackify-opcode/push-empty-cons prog))
+
+;; Pop top of stack and write as new car of pair at new top of stack
+
+(define (build/set-car prog)
+ (build/single-opcode stackify-opcode/pop-and-set-car prog))
+
+;; Pop top of stack and write as new cdr of pair at new top of stack
+
+(define (build/set-cdr prog)
+ (build/single-opcode stackify-opcode/pop-and-set-cdr prog))
+
+;; Pop N elements off the stack, and make an N-element vector with them
+;; TOS is element 0
+
+(define (build/make-vector n prog)
+ (build/fast n
+ stackify/fast-vector-opcodes
+ stackify-opcode/push-vector
+ prog))
+
+;; Push an N-element vector full of #f on the stack
+
+(define (build/make-empty-vector n prog)
+ (build/natural stackify-opcode/push-empty-vector
+ n
+ prog))
+
+;; Pop top of stack and write at element N of vector at new top of stack
+
+(define (build/vector-set n prog)
+ (build/fast n
+ stackify/fast-vector-set-opcodes
+ stackify-opcode/pop-and-vector-set
+ prog))
+
+;; Pop N elements off the stack, and make an N-element record with them
+;; TOS is element 0
+
+(define (build/make-record n prog)
+ (build/fast n
+ stackify/fast-record-opcodes
+ stackify-opcode/push-record
+ prog))
+
+;; Push an N-element record full of #f on the stack
+
+(define (build/make-empty-record n prog)
+ (build/natural stackify-opcode/push-empty-record
+ n
+ prog))
+
+;; Pop top of stack and write at element N of record at new top of stack
+
+(define (build/record-set n prog)
+ (build/fast n
+ stackify/fast-record-set-opcodes
+ stackify-opcode/pop-and-record-set
+ prog))
+\f
+(define (build/vector obj prog curr-depth max-depth regmap)
+ (let ((len (vector-length obj)))
+ (let loop ((i len)
+ (prog prog)
+ (curr-depth* curr-depth)
+ (max-depth max-depth)
+ (regmap regmap))
+ (if (not (fix:> i 0))
+ (values (build/make-vector len prog)
+ (fix:max (fix:+ 1 curr-depth) max-depth)
+ regmap)
+ (let ((next-i (fix:- i 1)))
+ (call-with-values
+ (lambda ()
+ (build (vector-ref obj next-i)
+ prog
+ curr-depth*
+ max-depth
+ regmap))
+ (lambda (prog* max-depth* regmap*)
+ (loop next-i
+ prog*
+ (fix:+ curr-depth* 1)
+ max-depth*
+ regmap*))))))))
+
+
+(define (build/unique obj prog curr-depth max-depth regmap)
+ ;; Returns <program max-depth regmap>
+ (define (simple-pair sel1 sel2)
+ (call-with-values
+ (lambda ()
+ (build (sel1 obj) prog curr-depth max-depth regmap))
+ (lambda (prog* max-depth* regmap*)
+ (call-with-values
+ (lambda ()
+ (build (sel2 obj) prog* (fix:+ curr-depth 1) max-depth* regmap*))
+ (lambda (prog** max-depth** regmap**)
+ (values (build/simple-pair obj prog**)
+ (fix:max (fix:+ 2 curr-depth) max-depth**)
+ regmap**))))))
+
+ (cond ((walk/simple? obj)
+ (values (build/simple obj prog)
+ (fix:max (fix:+ curr-depth 1) max-depth)
+ regmap))
+ ((number? obj)
+ (cond ((recnum? obj)
+ (simple-pair real-part imag-part))
+ ((ratnum? obj)
+ (simple-pair numerator denominator))
+ (else
+ (error "build/unique: Unknown kind of number" obj))))
+ ((fake-compiled-block? obj)
+ (call-with-values
+ (lambda ()
+ (fluid-let ((*stackify/tag-base* *stackify/tag-next*))
+ (set! *stackify/tag-next*
+ (+ *stackify/tag-next*
+ (fake-block/ntags obj)))
+ (build/vector (fake-block/proxy obj)
+ prog curr-depth max-depth regmap)))
+ (lambda (prog* max-depth* regmap*)
+ (values
+ (build/single-opcode stackify-opcode/retag-cc-block
+ prog*)
+ max-depth*
+ regmap*))))
+ ((pair? obj)
+ (let loop ((n 0)
+ (obj obj)
+ (prog prog)
+ (curr-depth curr-depth)
+ (max-depth max-depth)
+ (regmap regmap))
+ (call-with-values
+ (lambda ()
+ (build (car obj) prog curr-depth max-depth regmap))
+ (lambda (prog* max-depth* regmap*)
+ (let ((next (cdr obj)))
+ (if (or (not (pair? next))
+ (stackify/shared? next))
+ (call-with-values
+ (lambda ()
+ (build next prog* (fix:+ curr-depth 1)
+ max-depth* regmap*))
+ (lambda (prog** max-depth** regmap**)
+ (values (build/cons* n prog**)
+ (fix:max (fix:+ 2 curr-depth) max-depth**)
+ regmap**)))
+ (begin
+ (stackify/count/decrement! next)
+ (loop (fix:+ n 1)
+ next
+ prog*
+ (fix:+ curr-depth 1)
+ max-depth*
+ regmap*))))))))
+ ((%record? obj)
+ (let ((len (%record-length obj)))
+ (let loop ((i len)
+ (prog prog)
+ (curr-depth* curr-depth)
+ (max-depth max-depth)
+ (regmap regmap))
+ (if (not (fix:> i 0))
+ (values (build/make-record len prog)
+ (fix:max (fix:+ 1 curr-depth) max-depth)
+ regmap)
+ (let ((next-i (fix:- i 1)))
+ (call-with-values
+ (lambda ()
+ (build (%record-ref obj next-i)
+ prog
+ curr-depth*
+ max-depth
+ regmap))
+ (lambda (prog* max-depth* regmap*)
+ (loop next-i
+ prog*
+ (fix:+ curr-depth* 1)
+ max-depth*
+ regmap*))))))))
+ ((vector? obj)
+ (build/vector obj prog curr-depth max-depth regmap))
+ (else
+ (error "build/unique: Unknown kind of object" obj))))
+\f
+(define (build/cyclic obj prog curr-depth max-depth regmap)
+ ;; Outer reference to cyclic object
+ ;; Returns <program max-depth regmap>
+ (call-with-values
+ (lambda ()
+ (regmap/allocate regmap obj))
+ (lambda (regmap* place)
+ (cond ((or (walk/simple? obj)
+ (number? obj)
+ (fake-compiled-block? obj))
+ (error "build/cyclic: Cyclic what?" obj))
+ ((pair? obj)
+ (call-with-values
+ (lambda ()
+ (build (car obj)
+ (build/store place (build/empty-cons prog))
+ (fix:+ curr-depth 1)
+ max-depth regmap*))
+ (lambda (prog* max-depth* regmap**)
+ (call-with-values
+ (lambda ()
+ (build (cdr obj)
+ (build/set-car prog*)
+ (fix:+ curr-depth 1)
+ max-depth* regmap**))
+ (lambda (prog** max-depth** regmap***)
+ (values (build/set-cdr prog**)
+ (fix:max (fix:+ curr-depth 1) max-depth**)
+ regmap***))))))
+ ((%record? obj)
+ (let ((len (%record-length obj))
+ (curr-depth (fix:+ curr-depth 1)))
+ (let loop ((i len)
+ (prog (build/store
+ place
+ (build/make-empty-record len prog)))
+ (max-depth max-depth)
+ (regmap regmap*))
+ (if (not (fix:> i 0))
+ (values prog
+ (fix:max curr-depth max-depth)
+ regmap)
+ (let ((next-i (fix:- i 1)))
+ (call-with-values
+ (lambda ()
+ (build (%record-ref obj next-i)
+ prog
+ curr-depth
+ max-depth
+ regmap))
+ (lambda (prog* max-depth* regmap*)
+ (loop next-i
+ (build/record-set next-i prog*)
+ max-depth*
+ regmap*))))))))
+ ((vector? obj)
+ (let ((len (vector-length obj))
+ (curr-depth (fix:+ curr-depth 1)))
+ (let loop ((i len)
+ (prog (build/store
+ place
+ (build/make-empty-vector len prog)))
+ (max-depth max-depth)
+ (regmap regmap*))
+ (if (not (fix:> i 0))
+ (values prog
+ (fix:max curr-depth max-depth)
+ regmap)
+ (let ((next-i (fix:- i 1)))
+ (call-with-values
+ (lambda ()
+ (build (vector-ref obj next-i)
+ prog
+ curr-depth
+ max-depth
+ regmap))
+ (lambda (prog* max-depth* regmap*)
+ (loop next-i
+ (build/vector-set next-i prog*)
+ max-depth*
+ regmap*))))))))
+ (else
+ (error "build/cyclic: Unknown kind of object" obj))))))
+\f
+(define (build/shared obj prog curr-depth max-depth regmap)
+ ;; First-reference to shared non-cyclic object
+ ;; Returns <program max-depth regmap>
+ (call-with-values
+ (lambda ()
+ (build/unique obj prog curr-depth max-depth regmap))
+ (lambda (prog* max-depth* regmap*)
+ (call-with-values
+ (lambda ()
+ (regmap/allocate regmap* obj))
+ (lambda (regmap** place)
+ (values (build/store place prog*)
+ max-depth*
+ regmap**))))))
+
+(define (build obj prog curr-depth max-depth regmap)
+ ;; Returns <program max-depth regmap>
+ (if debug?
+ (write-debug-record/1 curr-depth prog))
+ (cond ((walk/trivial? obj)
+ (values (build/trivial obj prog)
+ (fix:max (fix:+ curr-depth 1) max-depth)
+ regmap))
+ ((fake-compiled-procedure? obj)
+ (with-values (lambda ()
+ (build (fake-procedure/block obj)
+ prog
+ curr-depth
+ max-depth
+ regmap))
+ (lambda (prog* max-depth* regmap*)
+ (values
+ (build/natural stackify-opcode/cc-block-to-entry
+ (fake-procedure/label-value obj)
+ prog*)
+ max-depth*
+ regmap*))))
+ (else
+ (let ((info (stackify/count/decrement! obj)))
+ (cond ((not (fix:= (vector-ref info 1) 1))
+ ;; Nth reference to a previously-built object
+ ;; Note: We must sequence regmap correctly...
+ (let ((prog* (build/lookup obj prog regmap)))
+ (values prog*
+ (fix:max (fix:+ curr-depth 1) max-depth)
+ (if (fix:= (vector-ref info 1) (vector-ref info 0))
+ ;; last reference to shared object
+ (regmap/forget regmap obj)
+ regmap))))
+ ((fix:= (vector-ref info 0) 1)
+ ;; Singleton reference
+ (build/unique obj prog curr-depth max-depth regmap))
+ ((vector-ref info 2)
+ ;; Outer reference to a cyclic structure
+ (build/cyclic obj prog curr-depth max-depth regmap))
+ (else
+ ;; First reference to shared non-cyclic object
+ (build/shared obj prog curr-depth max-depth regmap)))))))
+\f
+;;; Stackify escapes for construction of compiled code blocks
+;; Note that fake-compiled-procedure and fake-compiled-blocks are
+;; also escapes, but they take more work.
+
+(define-structure (stackify-escape
+ (constructor stackify-escape/make)
+ (conc-name stackify-escape/))
+ (kind false read-only true)
+ (contents false read-only true))
+
+(define (stackify/make-uuo-arity arity)
+ (stackify-escape/make 'arity arity))
+
+(define (stackify/make-label-descriptor code-word offset)
+ (stackify-escape/make 'label-descriptor (cons code-word offset)))
+
+(define (stackify/make-label-relative-entry tagno)
+ (stackify-escape/make 'label-relative-entry tagno))
+
+(define (stackify/make-nm-header length)
+ (stackify-escape/make 'nm-header length))
+
+(define (stackify/make-linkage-header kind count)
+ (stackify-escape/make kind count))
+
+;; These two are truly the identity procedure
+
+(define (stackify/make-uuo-name name)
+ name)
+
+(define (stackify/make-var-ref-entry name)
+ name)
+\f
+;;; Top level
+
+(define (stackify ntags obj)
+ (define (core)
+ (fluid-let ((*stackify/table* (stackify/make-table))
+ (*stackify/tag-base* 0)
+ (*stackify/tag-next* ntags))
+ (walk obj)
+ (call-with-values
+ (lambda ()
+ (build obj (stackify/empty-program) 0 0 (regmap/empty)))
+ (lambda (prog max-depth regmap)
+ (stackify/finalize-program prog
+ max-depth
+ (regmap/max-entries regmap))))))
+ (if (not debug?)
+ (core)
+ (begin
+ (stackify/setup-debug!)
+ (with-output-to-file debug? core))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: stackops.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; C-output fake object assembler
+;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;; Numbers in the string table are encoded by a very simple scheme:
+;; The first byte is the least significant byte, and so on.
+;; A byte encodes 7 bits of the number being encoded.
+;; Any byte whose most-significant bit (bit 7) is 0 denotes the end
+;; of the substring encoding the number.
+;; Thus, a number below 128 can be encoded in a single byte.
+;; A number below 16384 can be encoded in two bytes, and so on.
+;; Unlike UTF8, numbers with an arbitrary number of bits can be
+;; encoded. Of course, the string-search properties of UTF8 are not
+;; present, but they are not necessary here.
+
+;; String-like objects (strings, bit strings) consist of an encoded
+;; length followed by the string contents
+
+;; - For character strings, the string is the string itself
+;; - For floats, the string is some C-parseable representation of the
+;; float (e.g. F notation), in double-precision.
+;; - For bit strings, the string is numeric value (little endian) of
+;; the contents.
+
+;;; General objects
+
+(define-syntax define-enumeration
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (let ((name (cadr form))
+ (elements (cddr form)))
+ `(BEGIN
+ ,@(let loop ((n 0)
+ (elements elements)
+ (code '())
+ (bindings '()))
+ (if (not (pair? elements))
+ (reverse!
+ (cons `(define ,(symbol-append '* name '*)
+ '#(,@(reverse! bindings)))
+ code))
+ (let* ((next (car elements))
+ (suffix (if (pair? next)
+ (car next)
+ next))
+ (n (if (not (pair? next))
+ n
+ (let ((m (cadr next)))
+ (if (< m n)
+ (error "define-enumeration: Overlap"
+ next)
+ m)))))
+ (let ((name (symbol-append name '/ suffix)))
+ (loop (+ n 1)
+ (cdr elements)
+ (cons `(DEFINE-INTEGRABLE ,name ,n)
+ code)
+ (cons `(,name ,n) bindings)))))))))))
+
+;; Given how ulongs are represented (first add one), and that
+;; the 0 opcode is illegal, there should only be null characters
+;; in the output string if a component string contained a null
+;; character itself. Obviously these could be escaped, but fortunately,
+;; at least gcc allows null characters within strings just fine.
+;; Furthermore, if we ever gzip the strings, there will be null characters
+;; anyway.
+
+(define-enumeration stackify-opcode
+
+;; General objects
+
+illegal ; Make null characters very rare
+escape ; For future growth
+push-+fixnum ; magnitude in string table
+push--fixnum ; magnitude in string table
+push-+integer ; digit string mag. in string table
+push--integer ; digit string mag. in string table
+push-false
+push-true
+push-nil
+push-flonum ; decimal string in string table
+push-cons-ratnum
+push-cons-recnum
+push-string ; in string table
+push-symbol ; name in string table
+push-uninterned-symbol ; name in string table
+push-char ; char bits + char code in string table
+push-bit-string ; length + little-endian
+push-empty-cons
+pop-and-set-car
+pop-and-set-cdr
+push-cons*
+push-empty-vector ; length in string table
+pop-and-vector-set ; length in string table
+push-vector ; length in string table
+push-empty-record ; length in string table
+pop-and-record-set ; length in string table
+push-record ; length in string table
+push-lookup ; length in string table
+store ; length in string table
+push-constant ; length in string table
+push-unassigned
+push-primitive ; arity + name in string table
+push-primitive-lexpr ; name in string table
+push-nm-header ; length in string table
+push-label-entry ; rel. dispatch off. in string table
+push-linkage-header-operator ; length in string table
+push-linkage-header-reference ; length in string table
+push-linkage-header-assignment ; length in string table
+push-linkage-header-global ; length in string table
+push-linkage-header-closure ; length in string table
+push-ulong ; value in string table
+push-label-descriptor ; code word + offset in string table
+cc-block-to-entry ; entry offset in string table
+retag-cc-block ; no arguments
+push-return-code ; datum in string table
+;; 44
+
+;; Fast fixnums
+
+(push-0 #o200)
+push-1
+push-2
+push-3
+push-4
+push-5
+push-6
+push--1
+;; 8
+
+;; Fast pairs
+
+(push-cons*-0 #o210)
+push-cons*-1
+push-cons*-2
+push-cons*-3
+push-cons*-4
+push-cons*-5
+push-cons*-6
+push-cons*-7
+;; 8
+
+;; Fast vectors
+
+(pop-and-vector-set-0 #o220)
+pop-and-vector-set-1
+pop-and-vector-set-2
+pop-and-vector-set-3
+pop-and-vector-set-4
+pop-and-vector-set-5
+pop-and-vector-set-6
+pop-and-vector-set-7
+push-vector-1
+push-vector-2
+push-vector-3
+push-vector-4
+push-vector-5
+push-vector-6
+push-vector-7
+push-vector-8
+;; 16
+
+;; Fast records
+
+(pop-and-record-set-0 #o240)
+pop-and-record-set-1
+pop-and-record-set-2
+pop-and-record-set-3
+pop-and-record-set-4
+pop-and-record-set-5
+pop-and-record-set-6
+pop-and-record-set-7
+push-record-1
+push-record-2
+push-record-3
+push-record-4
+push-record-5
+push-record-6
+push-record-7
+push-record-8
+;; 16
+
+;; Fast register lookup
+
+(push-lookup-0 #o260)
+push-lookup-1
+push-lookup-2
+push-lookup-3
+push-lookup-4
+push-lookup-5
+push-lookup-6
+push-lookup-7
+;; 8
+
+;; Fast register assignment
+
+(store-0 #o270)
+store-1
+store-2
+store-3
+store-4
+store-5
+store-6
+store-7
+;; 8
+
+;; Fast primitives
+
+(push-primitive-0 #o300) ; name in string table
+push-primitive-1 ; name in string table
+push-primitive-2 ; name in string table
+push-primitive-3 ; name in string table
+push-primitive-4 ; name in string table
+push-primitive-5 ; name in string table
+push-primitive-6 ; name in string table
+push-primitive-7 ; name in string table
+;; 8
+)
+\f
+(define stackify/fast-fixnum-opcodes
+ (vector stackify-opcode/push-0
+ stackify-opcode/push-1
+ stackify-opcode/push-2
+ stackify-opcode/push-3
+ stackify-opcode/push-4
+ stackify-opcode/push-5
+ stackify-opcode/push-6))
+
+(define stackify/fast-cons*-opcodes
+ (vector
+ stackify-opcode/push-cons*-0
+ stackify-opcode/push-cons*-1
+ stackify-opcode/push-cons*-2
+ stackify-opcode/push-cons*-3
+ stackify-opcode/push-cons*-4
+ stackify-opcode/push-cons*-5
+ stackify-opcode/push-cons*-6
+ stackify-opcode/push-cons*-7))
+
+(define stackify/fast-vector-set-opcodes
+ (vector
+ stackify-opcode/pop-and-vector-set-0
+ stackify-opcode/pop-and-vector-set-1
+ stackify-opcode/pop-and-vector-set-2
+ stackify-opcode/pop-and-vector-set-3
+ stackify-opcode/pop-and-vector-set-4
+ stackify-opcode/pop-and-vector-set-5
+ stackify-opcode/pop-and-vector-set-6
+ stackify-opcode/pop-and-vector-set-7))
+
+(define stackify/fast-vector-opcodes
+ (vector
+ #f
+ stackify-opcode/push-vector-1
+ stackify-opcode/push-vector-2
+ stackify-opcode/push-vector-3
+ stackify-opcode/push-vector-4
+ stackify-opcode/push-vector-5
+ stackify-opcode/push-vector-6
+ stackify-opcode/push-vector-7
+ stackify-opcode/push-vector-8))
+
+(define stackify/fast-record-set-opcodes
+ (vector
+ stackify-opcode/pop-and-record-set-0
+ stackify-opcode/pop-and-record-set-1
+ stackify-opcode/pop-and-record-set-2
+ stackify-opcode/pop-and-record-set-3
+ stackify-opcode/pop-and-record-set-4
+ stackify-opcode/pop-and-record-set-5
+ stackify-opcode/pop-and-record-set-6
+ stackify-opcode/pop-and-record-set-7))
+
+(define stackify/fast-record-opcodes
+ (vector
+ #f
+ stackify-opcode/push-record-1
+ stackify-opcode/push-record-2
+ stackify-opcode/push-record-3
+ stackify-opcode/push-record-4
+ stackify-opcode/push-record-5
+ stackify-opcode/push-record-6
+ stackify-opcode/push-record-7
+ stackify-opcode/push-record-8))
+
+(define stackify/fast-lookup-opcodes
+ (vector
+ stackify-opcode/push-lookup-0
+ stackify-opcode/push-lookup-1
+ stackify-opcode/push-lookup-2
+ stackify-opcode/push-lookup-3
+ stackify-opcode/push-lookup-4
+ stackify-opcode/push-lookup-5
+ stackify-opcode/push-lookup-6
+ stackify-opcode/push-lookup-7))
+
+(define stackify/fast-store-opcodes
+ (vector
+ stackify-opcode/store-0
+ stackify-opcode/store-1
+ stackify-opcode/store-2
+ stackify-opcode/store-3
+ stackify-opcode/store-4
+ stackify-opcode/store-5
+ stackify-opcode/store-6
+ stackify-opcode/store-7))
+
+(define stackify/fast-primitive-opcodes
+ (vector
+ stackify-opcode/push-primitive-0
+ stackify-opcode/push-primitive-1
+ stackify-opcode/push-primitive-2
+ stackify-opcode/push-primitive-3
+ stackify-opcode/push-primitive-4
+ stackify-opcode/push-primitive-5
+ stackify-opcode/push-primitive-6
+ stackify-opcode/push-primitive-7))
+\f
+(define *stackify/opcode-name* #f)
+
+(define (stackify/setup-debug!)
+ (or *stackify/opcode-name*
+ (let* ((result (make-vector 256 #f))
+ (vec *stackify-opcode*)
+ (len (vector-length vec)))
+ (do ((i 0 (1+ i)))
+ ((>= i len) unspecific)
+ (let ((binding (vector-ref vec i)))
+ (vector-set! result (cadr binding) (car binding))))
+ (set! *stackify/opcode-name* result)
+ unspecific)))
+
+(define (stackify/c-quotify str)
+ (let* ((len (string-length str))
+ (res (make-string len)))
+ (do ((i 0 (1+ i)))
+ ((>= i len) res)
+ (let ((c (string-ref str i)))
+ (case c
+ ((#\*)
+ (string-set! res i #\S))
+ ((#\- #\/)
+ (string-set! res i #\_))
+ ((#\+)
+ (string-set! res i #\P))
+ (else
+ (string-set! res i c)))))))
+
+(define (stackify/dump-c-enums output)
+ (with-output-to-file output
+ (lambda ()
+ (for-each
+ write-string
+ (let ((time (get-decoded-time)))
+ (list "/* Emacs: this is -*- C -*- code. */\n\n"
+ "#ifndef STACKOPS_H\n"
+ "#define STACKOPS_H\n\n"
+ "/* C code produced\n "
+ (decoded-time/date-string time)
+ " at "
+ (decoded-time/time-string time)
+ "\n */\n\n"
+ "typedef enum\n"
+ "{\n")))
+ (let* ((vec *stackify-opcode*)
+ (len (vector-length vec))
+ (max -1))
+ (do ((i 0 (1+ i)))
+ ((>= i len) unspecific)
+ (let* ((binding (vector-ref vec i))
+ (value (cadr binding)))
+ (if (> value max)
+ (set! max value))
+ (for-each
+ write-string
+ (list "\t"
+ (stackify/C-quotify (symbol-name (car binding)))
+ " = 0"
+ (if (zero? value)
+ ""
+ (number->string value 8))
+ ",\n"))))
+ (for-each
+ write-string
+ (list "\t"
+ "N_STACKIFY_OPCODE = "
+ (number->string (1+ max))
+ "\n")))
+ (for-each
+ write-string
+ (list "} stackify_opcode_t;\n\n"
+ "#endif /* STACKOPS_H */\n")))))
+++ /dev/null
-#!/bin/csh -f
-
-make $*
-rm -f *.sync
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: traditional.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; C-output fake assembler and linker
+;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Object constructors
+;; This is the 'traditional' way, i.e. when stackify is not used
+;; It generates C code to explicitly construct the objects.
+
+(define num)
+(define new-variables)
+
+(define (generate-variable-name)
+ (let ((var (string-append "tmpObj" (number->string num))))
+ (set! new-variables (cons var new-variables))
+ (set! num (1+ num))
+ var))
+
+(define-integrable (table/find table value)
+ ;; assv ?
+ (assq value table))
+
+(define trivial-objects
+ (list #f #t '() unspecific))
+
+(define (trivial? object)
+ (or (memq object trivial-objects)
+ (guaranteed-fixnum? object)
+ (reference-trap? object)))
+
+(define *depth-limit* 2)
+
+(define (name-if-complicated node depth)
+ (cond ((fake-compiled-block? node)
+ (let ((name (fake-block/name node)))
+ (set! new-variables (cons name new-variables))
+ name))
+ ((or (%record? node)
+ (vector? node)
+ (> depth *depth-limit*))
+ (generate-variable-name))
+ (else
+ false)))
+
+(define (build-table nodes)
+ (map cdr
+ (sort (sort/enumerate
+ (list-transform-positive
+ (let loop ((nodes nodes)
+ (table '()))
+ (if (null? nodes)
+ table
+ (loop (cdr nodes)
+ (insert-in-table (car nodes)
+ 0
+ table))))
+ (lambda (pair)
+ (cdr pair))))
+ (lambda (entry1 entry2)
+ (let ((obj1 (cadr entry1))
+ (obj2 (cadr entry2)))
+ (if (not (fake-compiled-block? obj2))
+ (or (fake-compiled-block? obj1)
+ (< (car entry1) (car entry2)))
+ (and (fake-compiled-block? obj1)
+ (< (fake-block/index obj1)
+ (fake-block/index obj2)))))))))
+\f
+;; Hack to make sort a stable sort
+
+(define (sort/enumerate l)
+ (let loop ((l l) (n 0) (l* '()))
+ (if (null? l)
+ l*
+ (loop (cdr l)
+ (1+ n)
+ (cons (cons n (car l))
+ l*)))))
+
+(define (insert-in-table node depth table)
+ (cond ((trivial? node)
+ table)
+ ((table/find table node)
+ => (lambda (pair)
+ (if (not (cdr pair))
+ (set-cdr! pair (generate-variable-name)))
+ table))
+ (else
+ (let* ((name (name-if-complicated node depth))
+ (depth* (if name 1 (1+ depth)))
+ (table (cons (cons node name) table)))
+
+ (define-integrable (do-vector-like node vlength vref)
+ (let loop ((table table)
+ (i (vlength node)))
+ (if (zero? i)
+ table
+ (let ((i-1 (-1+ i)))
+ (loop (insert-in-table (vref node i-1)
+ depth*
+ table)
+ i-1)))))
+
+ (cond ((pair? node)
+ ;; Special treatment on the CDR because of RCONSM.
+ (insert-in-table
+ (car node)
+ depth*
+ (insert-in-table (cdr node)
+ (if name 1 depth)
+ table)))
+ ((vector? node)
+ (do-vector-like node vector-length vector-ref))
+ ((or (fake-compiled-procedure? node)
+ (fake-compiled-block? node))
+ table)
+ ((%record? node)
+ (do-vector-like node %record-length %record-ref))
+ (else
+ ;; Atom
+ table))))))
+\f
+(define (top-level-constructor object&name)
+ ;; (values prefix suffix)
+ (let ((name (cdr object&name))
+ (object (car object&name)))
+ (cond ((pair? object)
+ (values '()
+ (list name " = (CONS (SHARP_F, SHARP_F));\n\t")))
+ ((fake-compiled-block? object)
+ (set! *subblocks* (cons object *subblocks*))
+ (values (list name " = (initialize_subblock (\""
+ (fake-block/c-proc object)
+ "\"));\n\t")
+ '()))
+ ((fake-compiled-procedure? object)
+ (values '()
+ (list name " = "
+ (compiled-procedure-constructor
+ object)
+ ";\n\t")))
+ ((reference-trap? object)
+ (if (not (unassigned-reference-trap? object))
+ (error "Can't dump reference trap" object)
+ (values '()
+ (list name
+ " = "
+ (->simple-C-object object)))))
+ ((%record? object)
+ (values '()
+ (list name " = (ALLOCATE_RECORD ("
+ (number->string (%record-length object))
+ "));\n\t")))
+ ((vector? object)
+ (values '()
+ (list name " = (ALLOCATE_VECTOR ("
+ (number->string (vector-length object))
+ "));\n\t")))
+ (else
+ (values '()
+ (list name "\n\t = "
+ (->simple-C-object object)
+ ";\n\t"))))))
+
+(define (top-level-updator object&name table)
+ (let ((name (cdr object&name))
+ (object (car object&name)))
+
+ (define-integrable (do-vector-like object vlength vref vset-name)
+ (let loop ((i (vlength object))
+ (code '()))
+ (if (zero? i)
+ code
+ (let ((i-1 (- i 1)))
+ (loop i-1
+ `(,vset-name " (" ,name ", "
+ ,(number->string i-1) ", "
+ ,(constructor (vref object i-1)
+ table)
+ ");\n\t"
+ ,@code))))))
+
+ (cond ((pair? object)
+ (list "SET_PAIR_CAR (" name ", "
+ (constructor (car object) table) ");\n\t"
+ "SET_PAIR_CDR (" name ", "
+ (constructor (cdr object) table) ");\n\t"))
+ ((or (fake-compiled-block? object)
+ (fake-compiled-procedure? object)
+ (reference-trap? object))
+ '(""))
+ ((%record? object)
+ (do-vector-like object %record-length %record-ref "RECORD_SET"))
+ ((vector? object)
+ (do-vector-like object vector-length vector-ref "VECTOR_SET"))
+ (else
+ '("")))))
+\f
+(define (constructor object table)
+ (let process ((object object))
+ (cond ((table/find table object) => cdr)
+ ((pair? object)
+ (cond ((or (not (pair? (cdr object)))
+ (table/find table (cdr object)))
+ (string-append "(CONS (" (process (car object)) ", "
+ (process (cdr object)) "))"))
+ (else
+ (let loop ((npairs 0)
+ (object object)
+ (frobs '()))
+ (if (and (pair? object) (not (table/find table object)))
+ (loop (1+ npairs)
+ (cdr object)
+ (cons (car object) frobs))
+ ;; List is reversed to call rconsm
+ (string-append
+ "(RCONSM (" (number->string (1+ npairs))
+ (apply string-append
+ (map (lambda (frob)
+ (string-append ",\n\t\t"
+ (process frob)))
+ (cons object frobs)))
+ "))"))))))
+ ((fake-compiled-procedure? object)
+ (compiled-procedure-constructor object))
+ ((reference-trap? object)
+ (->simple-C-object object))
+ ((or (fake-compiled-block? object)
+ (vector? object)
+ (%record? object))
+ (error "constructor: Can't build directly"
+ object))
+ (else
+ (->simple-C-object object)))))
+
+(define (compiled-procedure-constructor object)
+ (string-append "(CC_BLOCK_TO_ENTRY ("
+ (fake-procedure/block-name object)
+ ", "
+ (number->string
+ (fake-procedure/label-tag object))
+ "))"))
+\f
+(define (top-level-constructors table)
+ ;; (values prefix suffix)
+ ;; (append-map top-level-constructor table)
+ (let loop ((table (reverse table)) (prefix '()) (suffix '()))
+ (if (null? table)
+ (values prefix suffix)
+ (with-values (lambda () (top-level-constructor (car table)))
+ (lambda (prefix* suffix*)
+ (loop (cdr table)
+ (append prefix* prefix)
+ (append suffix* suffix)))))))
+
+(define (->constructors names objects)
+ ;; (values prefix-code suffix-code)
+ (let* ((table (build-table objects)))
+ (with-values (lambda () (top-level-constructors table))
+ (lambda (prefix suffix)
+ (values prefix
+ (append suffix
+ (append-map (lambda (object&name)
+ (top-level-updator object&name table))
+ table)
+ (append-map
+ (lambda (name object)
+ (list (string-append name "\n\t = "
+ (constructor object table)
+ ";\n\t")))
+ names
+ objects)))))))
+\f
+(define (->simple-C-object object)
+ (cond ((symbol? object)
+ (let ((name (symbol->string object)))
+ (string-append "(C_SYM_INTERN ("
+ (number->string (string-length name))
+ "L, \"" (C-quotify-string name) "\"))")))
+ ((string? object)
+ (string-append "(C_STRING_TO_SCHEME_STRING ("
+ (number->string (string-length object))
+ "L, \"" (C-quotify-string object) "\"))"))
+ ((number? object)
+ (let process ((number object))
+ (cond ((flo:flonum? number)
+ (string-append "(DOUBLE_TO_FLONUM ("
+ (number->string number) "))"))
+ ((guaranteed-long? number)
+ (string-append "(LONG_TO_INTEGER ("
+ (number->string number) "L))"))
+ ((exact-integer? number)
+ (let ((bignum-string
+ (number->string (if (negative? number)
+ (- number)
+ number)
+ 16)))
+ (string-append "(DIGIT_STRING_TO_INTEGER ("
+ (if (negative? number)
+ "true, "
+ "false, ")
+ (number->string
+ (string-length bignum-string))
+ "L, \"" bignum-string "\"))")))
+ ((and (exact? number) (rational? number))
+ (string-append "(MAKE_RATIO ("
+ (process (numerator number))
+ ", " (process (denominator number))
+ "))"))
+ ((and (complex? number) (not (real? number)))
+ (string-append "(MAKE_COMPLEX ("
+ (process (real-part number))
+ ", " (process (imag-part number))
+ "))"))
+ (else
+ (error "scheme->C-object: Unknown number" number)))))
+ ((eq? #f object)
+ "SHARP_F")
+ ((eq? #t object)
+ "SHARP_T")
+ ((null? object)
+ "NIL")
+ ((eq? object unspecific)
+ "UNSPECIFIC")
+\f
+ ((primitive-procedure? object)
+ (let ((arity (primitive-procedure-arity object)))
+ (if (< arity -1)
+ (error "scheme->C-object: Unknown arity primitive" object)
+ (string-append "(MAKE_PRIMITIVE_PROCEDURE (\""
+ (symbol->string
+ (primitive-procedure-name object))
+ "\", "
+ (number->string arity)
+ "))"))))
+ ((char? object)
+ (string-append "(MAKE_CHAR ("
+ (let ((bits (char-bits object)))
+ (if (zero? bits)
+ "0"
+ (string-append "0x" (number->string bits 16))))
+ ", ((unsigned) "
+ (C-quotify-char (make-char (char-code object) 0))
+ ")))"))
+ ((bit-string? object)
+ (let ((string (number->string (bit-string->unsigned-integer object)
+ 16)))
+ (string-append "(DIGIT_STRING_TO_BIT_STRING ("
+ (number->string (bit-string-length object)) "L, "
+ (number->string (string-length string)) "L, \""
+ (string-reverse string)
+ "\"))")))
+ ((or (object-type? (object-type #t) object)
+ (object-type? (object-type '()) object))
+ ;; Random assorted objects, e.g.: #!rest, #!optional
+ (string-append "(MAKE_OBJECT ("
+ (if (object-type? (object-type #t) object)
+ "TC_CONSTANT"
+ "TC_NULL")
+ ", "
+ (number->string (object-datum object))
+ "L))"))
+ ;; This one is here for multi-definitions with no initial value
+ ((reference-trap? object)
+ (if (not (unassigned-reference-trap? object))
+ (error "Can't dump reference trap" object)
+ "UNASSIGNED_OBJECT"))
+ ;; Note: The following is here because of the Scode interpreter
+ ;; and the runtime system.
+ ;; They are not necessary for ordinary code.
+ ((interpreter-return-address? object)
+ (string-append "(MAKE_OBJECT (TC_RETURN_CODE, 0x"
+ (number->string (object-datum object) 16)
+ "))"))
+ (else
+ (error "->simple-C-object: unrecognized-type"
+ object))))
+\f
+(define char-set:C-char-quoted
+ (char-set-union
+ ;; Not char-set:not-graphic
+ (char-set-difference char-set:all
+ (char-set-intersection char-set:graphic
+ (ascii-range->char-set 0 #x7f)))
+ (char-set #\\ #\' (integer->char #xA0))))
+
+;; The following routine relies on the fact that Scheme and C use the
+;; same quoting convention for the named characters.
+
+(define (C-quotify-char char)
+ (cond ((not (char-set-member? char-set:C-char-quoted char))
+ (string #\' char #\'))
+ ((char-set-member? char-set:C-named-chars char)
+ (string-append
+ "'"
+ (let ((s (write-to-string (make-string 1 char))))
+ (substring s 1 (-1+ (string-length s))))
+ "'"))
+ ((char=? char #\')
+ "'\\''")
+ ((char=? char #\NUL)
+ "'\\0'")
+ (else
+ (string-append
+ "'\\"
+ (let ((s (number->string (char-code char) 8)))
+ (if (< (string-length s) 3)
+ (string-append (make-string (- 3 (string-length s)) #\0)
+ s)
+ s))
+ "'"))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: opncod.scm,v 4.73 2004/12/06 21:33:30 cph Exp $
+$Id: opncod.scm,v 4.74 2006/09/16 11:19:09 gjr Exp $
Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
-Copyright 1993,1997,1998,2001,2004 Massachusetts Institute of Technology
+Copyright 1993,1997,1998,2001,2004,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(pcfg/prefer-consequent!
(rtl:make-type-test (rtl:make-object->type expression) type)))))
+;; The C back end can't use generate-type-test for this because
+;; fixnums in the running system (e.g. 64 bits) may be too wide for
+;; the portable C output (which assumes no more than 32 bits)
+;; Important: This is only used by the open coded generic arithmetic.
+
+(define (generate-fixnum-test expression if-false if-true if-test)
+ (if (rtl:constant? expression)
+ (if (let ((value (rtl:constant-value expression)))
+ (and (fix:fixnum? value)
+ (fix:< value signed-fixnum/upper-limit)
+ (not (fix:< value signed-fixnum/lower-limit))))
+ (if-true)
+ (if-false))
+ (if-test
+ (pcfg/prefer-consequent!
+ (rtl:make-type-test (rtl:make-object->type expression)
+ (ucode-type fixnum))))))
+
;; A bunch of these directly use the open coding for fixnum arithmetic.
;; This is not reasonable since the port may not include such open codings.
(generic-default generic-op combination expressions
false finish)))
(let ((give-it-up (give-it-up)))
- (generate-binary-type-test (ucode-type fixnum) op1 op2
+ (generate-binary-fixnum-test op1 op2
(lambda ()
give-it-up)
(lambda ()
(lambda (combination expressions predicate? finish)
(let ((op1 (car expressions))
(op2 (cadr expressions)))
- (generate-binary-type-test (ucode-type fixnum) op1 op2
+ (generate-binary-fixnum-test op1 op2
(generic-default generic-op combination expressions predicate?
finish)
(lambda ()
'(0 1)
true)))
-(define (generate-binary-type-test type op1 op2 give-it-up do-it)
- (generate-type-test type op1
+(define (generate-binary-fixnum-test op1 op2 give-it-up do-it)
+ (generate-fixnum-test op1
give-it-up
(lambda ()
- (generate-type-test type op2
+ (generate-fixnum-test op2
give-it-up
do-it
(lambda (test)
(pcfg*scfg->scfg! test (do-it) (give-it-up)))))
(lambda (test)
- (generate-type-test type op2
+ (generate-fixnum-test op2
give-it-up
(lambda ()
(pcfg*scfg->scfg! test (do-it) (give-it-up)))
(let ((give-it-up
((generic-default generic-op combination expressions
false finish))))
- (generate-unary-type-test (ucode-type fixnum) op
+ (generate-unary-fixnum-test op
(lambda ()
give-it-up)
(lambda ()
(let ((fix-op (generic->fixnum-op generic-op)))
(lambda (combination expressions predicate? finish)
(let ((op (car expressions)))
- (generate-unary-type-test (ucode-type fixnum) op
+ (generate-unary-fixnum-test op
(generic-default generic-op combination expressions predicate?
finish)
(lambda ()
'(0)
true)))
-(define (generate-unary-type-test type op give-it-up do-it)
- (generate-type-test type op
+(define (generate-unary-fixnum-test op give-it-up do-it)
+ (generate-fixnum-test op
give-it-up
do-it
(lambda (test)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: script.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; Program to compile MIT/GNU Scheme
+
+;;; This is used to compile a part of the system written in Scheme.
+;;; This is the part of the system statically linked into the microcode
+;;; when using the C back end of the compiler.
+
+;; (set! compiler:invoke-c-compiler? false)
+
+(fluid-let ((compiler:invoke-c-compiler? false))
+ (with-working-directory-pathname
+ "../microcode"
+ (lambda ()
+ (if (or (not (file-exists? "utabmd.bin"))
+ (> (file-modification-time-indirect "utabmd.scm")
+ (file-modification-time-indirect "utabmd.bin")))
+ (sf "utabmd"))
+ (cbf "utabmd")))
+ (let ((dirs '("runtime" "sf" "cref" "compiler")))
+ (for-each
+ (lambda (dir)
+ (with-working-directory-pathname
+ (string-append "../" dir)
+ (lambda ()
+ (load (string-append dir ".sf")))))
+ dirs)
+ (for-each
+ (lambda (dir)
+ (with-working-directory-pathname
+ (string-append "../" dir)
+ (lambda ()
+ (load (string-append dir ".cbf"))
+ (cbf (string-append dir "-unx.pkd")))))
+ dirs))
+ (with-working-directory-pathname
+ "../star-parser"
+ (lambda ()
+ (load "compile.scm")
+ (cbf "parser-unx.pkd")))
+ )
/* -*-C-*-
-$Id: bignum.c,v 9.52 2004/10/17 21:35:40 cph Exp $
+$Id: bignum.c,v 9.53 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,1996,1997,2000 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
if (current_digit_bit_count == BIGNUM_DIGIT_LENGTH) {
if (index == 0) /* there is no guard bit */
goto finished;
- guard_bit_mask = (1 << (BIGNUM_DIGIT_LENGTH - 1));
+ guard_bit_mask = (1UL << (BIGNUM_DIGIT_LENGTH - 1));
rounding_correction = 1;
index -= 1;
} else {
/* -*-C-*-
-$Id: bintopsb.c,v 9.78 2006/08/28 16:58:24 cph Exp $
+$Id: bintopsb.c,v 9.79 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,1997,1998,2000 Massachusetts Institute of Technology
{
SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
- fast SCHEME_OBJECT accumulator, next_word, *scan;
+ fast SCHEME_OBJECT accumulator = ((SCHEME_OBJECT) 0), next_word, *scan;
the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, from));
bits_remaining = (BIT_STRING_LENGTH (the_bit_string));
#define DO_C_COMPILED_ENTRY(Code, Rel, Fre, Scn, Obj, FObj) \
COMPILER_BAD_STMT ("DO_C_COMPILED_ENTRY")
-#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj)
+#define DO_C_COMPILED_BLOCK(Code, Rel, Fre, Scn, Obj, FObj) \
COMPILER_BAD_STMT ("DO_C_COMPILED_BLOCK")
#endif /* HAS_COMPILER_SUPPORT */
/* -*-C-*-
-$Id: bitstr.c,v 9.65 2003/02/14 18:28:15 cph Exp $
+$Id: bitstr.c,v 9.66 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1987-2000 Massachusetts Institute of Technology
+Copyright (c) 1987-2000, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
static void EXFUN
(copy_bits, (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long));
+extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
\f
-static SCHEME_OBJECT
+SCHEME_OBJECT
DEFUN (allocate_bit_string, (length), long length)
{
long total_pointers;
/* -*-C-*-
-$Id: boot.c,v 9.118 2005/01/01 05:43:57 cph Exp $
+$Id: boot.c,v 9.119 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology
Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#include "ostop.h"
#include "ostty.h"
+#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
+#include <unistd.h>
+#else
extern PTR EXFUN (malloc, (unsigned int size));
+#endif
+
extern void EXFUN (free, (PTR ptr));
extern void EXFUN (init_exit_scheme, (void));
extern void EXFUN (Clear_Memory, (int, int, int));
#define ID_OS_NAME 8 /* OS name (string) */
#define ID_OS_VARIANT 9 /* OS variant (string) */
#define ID_STACK_TYPE 10 /* Scheme stack type (string) */
+#define ID_MACHINE_TYPE 11 /* Machine type (string) */
#ifdef USE_STACKLETS
#define STACK_TYPE_STRING "stacklets"
FAST_VECTOR_SET (Result, ID_STACK_TYPE,
(char_pointer_to_string
((unsigned char *) STACK_TYPE_STRING)));
+ FAST_VECTOR_SET (Result, ID_MACHINE_TYPE,
+ (char_pointer_to_string
+ ((unsigned char *) MACHINE_TYPE)));
PRIMITIVE_RETURN (Result);
}
/* -*-C-*-
-$Id: c.c,v 1.15 2003/02/14 18:28:25 cph Exp $
+$Id: c.c,v 1.16 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999, 2002 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
*/
+#include <string.h>
+#define LIARC_IN_MICROCODE
#include "liarc.h"
#include "prims.h"
#include "bignum.h"
\f
#ifdef BUG_GCC_LONG_CALLS
-extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_string,
+ (unsigned long, CONST unsigned char *));
extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
-extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
-extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_integer,
+ (Boolean, unsigned long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string,
+ (unsigned long, unsigned long, unsigned char *));
extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
+extern SCHEME_OBJECT EXFUN (memory_to_uninterned_symbol,
+ (unsigned long, unsigned char *));
-SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()) =
+SCHEME_OBJECT EXFUN ((* (constructor_kludge [11])), ()) =
{
((SCHEME_OBJECT EXFUN ((*), ())) memory_to_string),
((SCHEME_OBJECT EXFUN ((*), ())) memory_to_symbol),
((SCHEME_OBJECT EXFUN ((*), ())) long_to_integer),
((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_integer),
((SCHEME_OBJECT EXFUN ((*), ())) digit_string_to_bit_string),
- ((SCHEME_OBJECT EXFUN ((*), ())) make_primitive)
+ ((SCHEME_OBJECT EXFUN ((*), ())) make_primitive),
+ ((SCHEME_OBJECT EXFUN ((*), ())) memory_to_uninterned_symbol),
};
#endif /* BUG_GCC_LONG_CALLS */
extern long C_return_value, MAX_TRAMPOLINE;
extern void EXFUN (C_to_interface, (PTR));
extern void EXFUN (interface_initialize, (void));
-extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *));
+extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *));
extern int EXFUN (initialize_compiled_code_blocks, (void));
extern void * scheme_hooks_low, * scheme_hooks_high;
#define TRAMPOLINE_FUDGE 20
typedef SCHEME_OBJECT * EXFUN ((* code_block),
- (SCHEME_OBJECT *, unsigned long));
+ (SCHEME_OBJECT *, entry_count_t));
-typedef SCHEME_OBJECT * EXFUN ((* data_block), (unsigned long));
+typedef SCHEME_OBJECT * EXFUN ((* data_block), (entry_count_t));
+
+typedef SCHEME_OBJECT EXFUN ((* data_generator), (void));
+
+typedef void EXFUN ((* uninit_data), (void));
struct compiled_entry_s
{
- code_block code;
- unsigned long dispatch;
+ code_block code; /* C handler for this entry point */
+ entry_count_t dispatch; /* Internal dispatch tag */
};
+#define COMPILED_BLOCK_FLAG_DATA_ONLY 1
+
struct compiled_block_s
{
char * name;
- unsigned long nentries;
- unsigned long dispatch;
- data_block constructor;
+ union
+ {
+ uninit_data errgen; /* When not initialized yet */
+ data_block constructor; /* Data handler for this compiled block */
+ data_generator builder; /* Data generator for data-only cc blocks */
+ } data;
+ entry_count_t nentries; /* Number of entry points in this block */
+ entry_count_t dispatch; /* Base of dispatch for this block */
+ unsigned flags;
};
\f
int pc_zero_bits;
PSEUDO_STATIC long
initial_entry_number = -1;
-PSEUDO_STATIC unsigned long
+PSEUDO_STATIC entry_count_t
max_compiled_entries = 0,
compiled_entries_size = 0;
PSEUDO_STATIC struct compiled_entry_s *
compiled_entries = ((struct compiled_entry_s *) NULL);
-PSEUDO_STATIC unsigned long
+PSEUDO_STATIC entry_count_t
max_compiled_blocks = 0,
compiled_blocks_table_size = 0;
PSEUDO_STATIC struct compiled_block_s *
SCHEME_OBJECT *
DEFUN (trampoline_procedure, (trampoline, dispatch),
- SCHEME_OBJECT * trampoline AND unsigned long dispatch)
+ SCHEME_OBJECT * trampoline AND entry_count_t dispatch)
{
return (invoke_utility (((int) (* ((unsigned long *) trampoline))),
((long) (TRAMPOLINE_STORAGE (trampoline))),
}
SCHEME_OBJECT *
-DEFUN (no_data, (base_dispatch), unsigned long base_dispatch)
+DEFUN (no_data, (base_dispatch), entry_count_t base_dispatch)
{
return ((SCHEME_OBJECT *) NULL);
}
-SCHEME_OBJECT *
-DEFUN (uninitialized_data, (base_dispatch), unsigned long base_dispatch)
+void
+DEFUN_VOID (uninitialized_data)
{
/* Not yet assigned. Cannot construct data. */
error_external_return ();
+ /*NOTREACHED*/
}
SCHEME_OBJECT *
DEFUN (unspecified_code, (entry, dispatch),
- SCHEME_OBJECT * entry AND unsigned long dispatch)
+ SCHEME_OBJECT * entry AND entry_count_t dispatch)
{
exp_register = ((SCHEME_OBJECT) entry);
C_return_value = (ERR_EXECUTE_MANIFEST_VECTOR);
}
int
-DEFUN (declare_trampoline_block, (nentries), unsigned long nentries)
+DEFUN (declare_trampoline_block, (nentries), entry_count_t nentries)
{
int result;
return;
}
\f
-unsigned long
+entry_count_t
DEFUN (find_compiled_block, (name), char * name)
{
tree_node node = (tree_lookup (compiled_blocks_tree, name));
(name, decl_data, data_proc),
char * name
AND int EXFUN ((* decl_data), (void))
- AND SCHEME_OBJECT * EXFUN ((* data_proc), (unsigned long)))
+ AND SCHEME_OBJECT * EXFUN ((* data_proc), (entry_count_t)))
{
- unsigned long slot = (find_compiled_block (name));
+ entry_count_t slot = (find_compiled_block (name));
if (slot == max_compiled_blocks)
return (-1);
- if ((compiled_blocks_table[slot].constructor != uninitialized_data)
- && (compiled_blocks_table[slot].constructor != data_proc))
+ if ((compiled_blocks_table[slot].data.errgen != uninitialized_data)
+ && (compiled_blocks_table[slot].data.constructor != data_proc))
return (-1);
- compiled_blocks_table[slot].constructor = data_proc;
+ compiled_blocks_table[slot].flags &= (~ COMPILED_BLOCK_FLAG_DATA_ONLY);
+ compiled_blocks_table[slot].data.constructor = data_proc;
return (* decl_data) ();
}
DEFUN (initialize_subblock, (name), char * name)
{
SCHEME_OBJECT * ep, * block;
- unsigned long slot = (find_compiled_block (name));
+ entry_count_t slot = (find_compiled_block (name));
- if (slot == max_compiled_blocks)
+ if ((slot == max_compiled_blocks)
+ || ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY)
+ != 0))
error_external_return ();
- ep = ((* compiled_blocks_table[slot].constructor)
+ ep = ((* compiled_blocks_table[slot].data.constructor)
(compiled_blocks_table[slot].dispatch));
Get_Compiled_Block (block, ep);
return (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
}
-SCHEME_OBJECT *
+SCHEME_OBJECT
DEFUN (initialize_C_compiled_block, (argno, name),
int argno AND char * name)
{
- unsigned long slot;
+ SCHEME_OBJECT val;
+ entry_count_t slot;
slot = (find_compiled_block (name));
if (slot == max_compiled_blocks)
- return ((SCHEME_OBJECT *) NULL);
+ return (SHARP_F);
+
+ if ((compiled_blocks_table[slot].flags & COMPILED_BLOCK_FLAG_DATA_ONLY) != 0)
+ val = ((* compiled_blocks_table[slot].data.builder) ());
+ else
+ {
+ SCHEME_OBJECT * block;
- return ((* compiled_blocks_table[slot].constructor)
- (compiled_blocks_table[slot].dispatch));
+ block = ((* compiled_blocks_table[slot].data.constructor)
+ (compiled_blocks_table[slot].dispatch));
+ val = (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, block));
+ }
+ return (val);
}
\f
int
DEFUN (declare_compiled_code,
(name, nentries, decl_code, code_proc),
char * name
- AND unsigned long nentries
+ AND entry_count_t nentries
AND int EXFUN ((* decl_code), (void))
AND code_block code_proc)
{
- unsigned long slot = (find_compiled_block (name));
+ entry_count_t slot = (find_compiled_block (name));
if (slot != max_compiled_blocks)
{
return (-1);
if (old_code == unspecified_code)
{
- unsigned long counter, limit;
+ entry_count_t counter, limit;
counter = compiled_blocks_table[slot].dispatch;
limit = (counter + nentries);
}
else
{
- unsigned long dispatch = max_compiled_entries;
- unsigned long n_dispatch = (dispatch + nentries);
- unsigned long block_index = max_compiled_blocks;
+ entry_count_t dispatch = max_compiled_entries;
+ entry_count_t n_dispatch = (dispatch + nentries);
+ entry_count_t block_index = max_compiled_blocks;
if (n_dispatch < dispatch)
/* Wrap around */
if (n_dispatch >= compiled_entries_size)
{
struct compiled_entry_s * new_entries;
- unsigned long new_entries_size = ((compiled_entries_size == 0)
+ entry_count_t new_entries_size = ((compiled_entries_size == 0)
? 100
: ((compiled_entries_size * 3) / 2));
if (new_entries_size <= n_dispatch)
if (block_index >= compiled_blocks_table_size)
{
struct compiled_block_s * new_blocks;
- unsigned long new_blocks_size
+ entry_count_t new_blocks_size
= ((compiled_blocks_table_size == 0)
? 10
: ((compiled_blocks_table_size * 3) / 2));
max_compiled_blocks = (block_index + 1);
compiled_blocks_table[block_index].name = name;
+ compiled_blocks_table[block_index].flags = 0;
+ compiled_blocks_table[block_index].data.errgen = uninitialized_data;
compiled_blocks_table[block_index].nentries = nentries;
compiled_blocks_table[block_index].dispatch = dispatch;
- compiled_blocks_table[block_index].constructor = uninitialized_data;
for (block_index = dispatch; block_index < n_dispatch; block_index++)
{
}
return (* decl_code) ();
}
+\f
+int
+DEFUN (declare_data_object,
+ (name, data_proc),
+ char * name
+ AND SCHEME_OBJECT EXFUN ((* data_proc), (void)))
+{
+ entry_count_t slot;
+
+ slot = (find_compiled_block (name));
+ if (slot == max_compiled_blocks)
+ {
+ declare_compiled_code (name, 0, NO_SUBBLOCKS, unspecified_code);
+ slot = (find_compiled_block (name));
+ if (slot == max_compiled_blocks)
+ return (-1);
+ }
+
+ if ((compiled_blocks_table[slot].data.errgen != uninitialized_data)
+ && (compiled_blocks_table[slot].data.builder != data_proc))
+ return (-1);
+
+ compiled_blocks_table[slot].flags |= (COMPILED_BLOCK_FLAG_DATA_ONLY);
+ compiled_blocks_table[slot].data.builder = data_proc;
+
+ return (0);
+}
+
+int
+DEFUN (declare_compiled_code_mult, (nslots, slots),
+ unsigned nslots AND CONST struct liarc_code_S * slots)
+{
+ unsigned i;
+ int res = 0;
+
+ for (i = 0; (i < nslots); i++)
+ {
+ res = (declare_compiled_code (((char *) (slots[i].name)),
+ (slots[i].nentries),
+ NO_SUBBLOCKS,
+ (slots[i].code)));
+ if (res != 0)
+ break;
+ }
+ return (res);
+}
+int
+DEFUN (declare_compiled_data_mult, (nslots, slots),
+ unsigned nslots AND CONST struct liarc_data_S * slots)
+{
+ unsigned i;
+ int res = 0;
+
+ for (i = 0; (i < nslots); i++)
+ {
+ res = (declare_compiled_data (((char *) (slots[i].name)),
+ NO_SUBBLOCKS,
+ (slots[i].data)));
+ if (res != 0)
+ break;
+ }
+ return (res);
+}
+\f
/* For now */
extern SCHEME_OBJECT
PRIMITIVE_RETURN (ulong_to_integer (old_counter));
}
-typedef SCHEME_OBJECT * EXFUN
- ((* utility_table_entry), (long, long, long, long));
+typedef SCHEME_OBJECT * utility_result;
+
+typedef void EXFUN
+ ((* utility_table_entry), (utility_result *, long, long, long, long));
extern utility_table_entry utility_table[];
DEFUN (invoke_utility, (code, arg1, arg2, arg3, arg4),
int code AND long arg1 AND long arg2 AND long arg3 AND long arg4)
{
- return ((* utility_table[code]) (arg1, arg2, arg3, arg4));
+ utility_result res;
+
+ (* utility_table[code]) ((& res), arg1, arg2, arg3, arg4);
+
+ return ((SCHEME_OBJECT *) res);
}
\f
int
}
static unsigned int
-DEFUN (hex_digit_to_int, (h_digit), char h_digit)
+DEFUN (hex_digit_to_int, (h_digit), unsigned char h_digit)
{
unsigned int digit = ((unsigned int) h_digit);
SCHEME_OBJECT
DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits),
- long n_bits AND long n_digits AND char * digits)
+ unsigned long n_bits
+ AND unsigned long n_digits
+ AND unsigned char * digits)
{
extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long));
extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
- SCHEME_OBJECT result = (allocate_bit_string (n_bits));
+ SCHEME_OBJECT result = (allocate_bit_string ((long) n_bits));
unsigned int digit, mask;
long i, posn;
int j;
posn = 0;
clear_bit_string (result);
- for (i = 0; i < n_digits; i++)
+ for (i = 0; i < ((long) n_digits); i++)
{
digit = (hex_digit_to_int (*digits++));
for (j = 0, mask = 1;
/* This avoids consing the string and symbol if it already exists. */
SCHEME_OBJECT
-DEFUN (memory_to_symbol, (length, string),
- long length AND unsigned char * string)
+DEFUN (memory_to_uninterned_symbol, (length, string),
+ unsigned long length AND unsigned char * string)
{
- extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *));
- extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT));
- SCHEME_OBJECT symbol;
-
- symbol = (find_symbol (length, string));
- if (symbol != SHARP_F)
- return (symbol);
- return (string_to_symbol (memory_to_string (length, string)));
+ SCHEME_OBJECT name = (memory_to_string (length, string));
+ SCHEME_OBJECT res = (CONS (name, UNBOUND_OBJECT));
+ return (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, res));
}
static unsigned int
-DEFUN (digit_string_producer, (digit_ptr), char ** digit_ptr)
+DEFUN (digit_string_producer, (digit_ptr), PTR v_digit_ptr)
{
+ char ** digit_ptr = ((char **) v_digit_ptr);
char digit = ** digit_ptr;
* digit_ptr = ((* digit_ptr) + 1);
return (hex_digit_to_int (digit));
SCHEME_OBJECT
DEFUN (digit_string_to_integer, (negative_p, n_digits, digits),
- Boolean negative_p AND long n_digits AND char * digits)
+ Boolean negative_p
+ AND unsigned long n_digits
+ AND unsigned char * digits)
{
- char * digit = digits;
+ SCHEME_OBJECT bignum;
+ unsigned char * digit = digits;
+ extern SCHEME_OBJECT EXFUN (bignum_to_integer, (SCHEME_OBJECT));
+
+ bignum = (digit_stream_to_bignum (((int) n_digits),
+ digit_string_producer,
+ ((PTR) & digit),
+ 16,
+ ((int) negative_p)));
- return (digit_stream_to_bignum (((int) n_digits),
- digit_string_producer,
- ((PTR) & digit),
- 16,
- ((int) negative_p)));
+ return (bignum_to_integer (bignum));
}
\f
#ifdef USE_STDARG
/* -*-C-*-
-$Id: cmpint.c,v 1.104 2006/01/29 06:37:30 cph Exp $
+$Id: cmpint.c,v 1.105 2006/09/16 11:19:09 gjr Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,2000,2001,2002,2003 Massachusetts Institute of Technology
#define ENTER_SCHEME(ep) return (C_to_interface ((PTR) (ep)))
-#else /* CMPINT_USE_STRUCS */
+#else /* not CMPINT_USE_STRUCS */
typedef instruction * utility_result;
#define RETURN_TO_C(code) do \
{ \
- (*DSU_result) = interface_to_C_hook; \
+ (*DSU_result) = ((instruction *) interface_to_C_hook); \
C_return_value = (code); \
return; \
} while (0)
#define RETURN_TO_SCHEME(ep) do \
{ \
- (*DSU_result) = (ep); \
+ (*DSU_result) = ((instruction *) (ep)); \
return; \
} while (0)
RETURN_TO_C (PRIM_DONE);
}
\f
-#if (COMPILER_PROCESSOR_TYPE != COMPILER_IA32_TYPE)
-
-#define INVOKE_RETURN_ADDRESS() \
- RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()))
-
-#else /* COMPILER_IA32_TYPE */
-
static void EXFUN
(compiler_interrupt_common, (utility_result *, SCHEME_ADDR, SCHEME_OBJECT));
return; \
} while (0)
+#if (COMPILER_PROCESSOR_TYPE != COMPILER_IA32_TYPE)
+
+#define INVOKE_RETURN_ADDRESS() \
+ RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()))
+
+#else /* COMPILER_IA32_TYPE */
+
#define INVOKE_RETURN_ADDRESS() do \
{ \
if (((long) (ADDR_TO_SCHEME_ADDR (Free))) \
/* -*-C-*-
-$Id: c.h,v 1.9 2003/02/14 18:28:31 cph Exp $
+$Id: c.h,v 1.10 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
#define COMPILER_PROCESSOR_TYPE COMPILER_LOSING_C_TYPE
+#ifndef NATIVE_CODE_IS_C
+#define NATIVE_CODE_IS_C
+#endif
+
#define WRITE_LABEL_DESCRIPTOR(entry,kind,offset) do \
{ \
- SCHEME_OBJECT * ent = ((SCHEME_OBJECT *) (entry)); \
+ SCHEME_OBJECT * _ent = ((SCHEME_OBJECT *) (entry)); \
\
- COMPILED_ENTRY_FORMAT_WORD (entry) = (kind); \
- COMPILED_ENTRY_OFFSET_WORD (entry) = \
+ COMPILED_ENTRY_FORMAT_WORD (_ent) = (kind); \
+ COMPILED_ENTRY_OFFSET_WORD (_ent) = \
(WORD_OFFSET_TO_OFFSET_WORD (offset)); \
} while (0)
/* -*-C-*-
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
*/
-/* $Id: comlin.c,v 1.11 2003/02/14 18:28:18 cph Exp $
+/* $Id: comlin.c,v 1.12 2006/09/16 11:19:09 gjr Exp $
*
* This file contains the scheme command parser.
*
case BOOLEAN_KYWRD:
{
- boolean value;
+ boolean value = false;
if (*argument != '\0')
{
/* -*-C-*-
-$Id: compinit.c,v 1.6 2003/02/14 18:28:18 cph Exp $
+$Id: compinit.c,v 1.7 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-1999 Massachusetts Institute of Technology
+Copyright (c) 1992-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
*/
+#define LIARC_IN_MICROCODE
#include "liarc.h"
#undef DECLARE_COMPILED_CODE
#undef DECLARE_COMPILED_DATA
+#undef DECLARE_DATA_OBJECT
#define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) do \
{ \
extern int EXFUN (decl_code, (void)); \
extern SCHEME_OBJECT * EXFUN (code, \
- (SCHEME_OBJECT *, unsigned long)); \
+ (SCHEME_OBJECT *, entry_count_t)); \
int result = \
(declare_compiled_code (name, nentries, decl_code, code)); \
if (result != 0) \
#define DECLARE_COMPILED_DATA(name, decl_data, data) do \
{ \
extern int EXFUN (decl_data, (void)); \
- extern SCHEME_OBJECT * EXFUN (data, (unsigned long)); \
+ extern SCHEME_OBJECT * EXFUN (data, (entry_count_t)); \
int result = (declare_compiled_data (name, decl_data, data)); \
if (result != 0) \
return (result); \
} while (0)
+#define DECLARE_DATA_OBJECT(name, data) do \
+{ \
+ extern SCHEME_OBJECT EXFUN (data, (void)); \
+ \
+ int result = (declare_data_object (name, data)); \
+ if (result != 0) \
+ return (result); \
+} while (0)
+
int
DEFUN_VOID (initialize_compiled_code_blocks)
{
/* -*-C-*-
-$Id: comutl.c,v 1.33 2003/02/14 18:28:18 cph Exp $
+$Id: comutl.c,v 1.34 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
"Given the tag of a compiled object, return the object.")
{
#ifdef NATIVE_CODE_IS_C
- extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *));
- SCHEME_OBJECT * block, val;
-
- block = (initialize_C_compiled_block (1, (STRING_ARG (1))));
- val = ((block == ((SCHEME_OBJECT *) NULL))
- ? SHARP_F
- : (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, block)));
+ extern SCHEME_OBJECT EXFUN (initialize_C_compiled_block, (int, char *));
+ SCHEME_OBJECT val;
+
+ val = (initialize_C_compiled_block (1, (STRING_ARG (1))));
PRIMITIVE_RETURN (val);
#else
PRIMITIVE_RETURN (SHARP_F);
dnl Process this file with autoconf to produce a configure script.
AC_INIT([MIT/GNU Scheme], [14.17], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.11 2006/06/10 15:06:07 cph Exp $])
+AC_REVISION([$Id: configure.ac,v 1.12 2006/09/16 11:19:09 gjr Exp $])
AC_CONFIG_SRCDIR([boot.c])
AC_CONFIG_HEADERS([config.h])
AC_PROG_MAKE_SET
MODULE_BASES=
MODULE_CFLAGS="-DCOMPILE_AS_MODULE"
MODULE_LDFLAGS=
+COMPILED_DEFS=
+CMPAUXMDO=
+COMPILED_SOURCES_1=
+COMPILED_OBJECTS_1=
dnl Checks for programs.
AC_PROG_CC
i?86)
scheme_arch=i386
;;
+# x86_64)
+# scheme_arch=i386
+# CFLAGS="${CFLAGS} -m32"
+# LDFLAGS="${LDFLAGS} -m32"
+# ;;
m68k|m680?0)
scheme_arch=mc68k
;;
OPTIONAL_SOURCES="${OPTIONAL_SOURCES} cmpauxmd.m4"
OPTIONAL_OBJECTS="${OPTIONAL_OBJECTS} cmpauxmd.o"
GC_HEAD_FILES="${GC_HEAD_FILES} cmpintmd.h"
+ CMPAUXMDO="Ignore-me.o"
+else
+ AC_DEFINE([HAS_COMPILER_SUPPORT], [1],
+ [Define if architecture has native-code compiler support.])
+ AC_DEFINE([NATIVE_CODE_IS_C], [1],
+ [Define that the compiler outputs C code instead of binaries.])
+ test -f cmpauxmd.c || ${LN_S} cmpauxmd/c.c cmpauxmd.c
+ test -f cmpintmd.h || ${LN_S} cmpintmd/c.h cmpintmd.h
+ COMPILED_DEFS="${COMPILED_DEFS} -DCOMPILE_FOR_STATIC_LINKING"
+ COMPILED_SOURCES_1="\$(COMPILED_SOURCES)"
+ COMPILED_OBJECTS_1="\$(COMPILED_OBJECTS)"
+ OPTIONAL_SOURCES="${OPTIONAL_SOURCES} cmpauxmd.c unstackify.c compinit.c"
+ OPTIONAL_OBJECTS="${OPTIONAL_OBJECTS} cmpauxmd.o unstackify.o compinit.o"
+ GC_HEAD_FILES="${GC_HEAD_FILES} cmpintmd.h"
+ CMPAUXMDO="cmpauxmd.o"
fi
for base in ${OPTIONAL_BASES}; do
AC_SUBST_FILE([MODULE_RULES])
AC_SUBST([MODULE_CFLAGS])
AC_SUBST([MODULE_LDFLAGS])
+AC_SUBST([COMPILED_DEFS])
+AC_SUBST([CMPAUXMDO])
+AC_SUBST([COMPILED_SOURCES_1])
+AC_SUBST([COMPILED_OBJECTS_1])
AC_CONFIG_FILES([Makefile])
AC_OUTPUT
/* -*-C-*-
-$Id: confshared.h,v 11.8 2005/07/24 05:21:11 cph Exp $
+$Id: confshared.h,v 11.9 2006/09/16 11:19:09 gjr Exp $
-Copyright 2000,2002,2003 Massachusetts Institute of Technology
+Copyright 2000,2002,2003,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#define FASL_APOLLO_PRISM 17
#define FASL_ALPHA 18
#define FASL_RS6000 19
+#define FASL_PPC32 20
+#define FASL_X86_64 21
+#define FASL_PPC64 22
+#define FASL_IA64 23
\f
#ifdef vax
#define MACHINE_TYPE "vax"
#define FASL_INTERNAL_FORMAT FASL_VAX
-#define TYPE_CODE_LENGTH 6
#define HEAP_IN_LOW_MEMORY
/* Not on these, however */
#define MACHINE_TYPE "hp9000s800"
#endif
#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM
-#define TYPE_CODE_LENGTH 6
#define FLOATING_ALIGNMENT 0x7
/* Heap resides in data space, pointed at by space register 5.
#define FASL_INTERNAL_FORMAT FASL_68020
#endif
#define HEAP_IN_LOW_MEMORY
-#define TYPE_CODE_LENGTH 6
#endif /* hp9000s300 */
#ifdef sun3
# define MACHINE_TYPE "sun3"
# define FASL_INTERNAL_FORMAT FASL_68020
-# define TYPE_CODE_LENGTH 6
# define HEAP_IN_LOW_MEMORY
# define HAVE_DOUBLE_TO_LONG_BUG
#endif
#ifdef NeXT
# define MACHINE_TYPE "next"
# define FASL_INTERNAL_FORMAT FASL_68020
-# define TYPE_CODE_LENGTH 6
# define HEAP_IN_LOW_MEMORY
#endif
\f
#define FASL_INTERNAL_FORMAT FASL_IA32
#define HEAP_IN_LOW_MEMORY
-#define TYPE_CODE_LENGTH 6
#ifdef sequent
# define MACHINE_TYPE "sequent386"
# define MACHINE_TYPE "IA-32"
#endif
+#ifdef NATIVE_CODE_IS_C
+#undef HEAP_IN_LOW_MEMORY
+#endif
+
#endif /* __IA32__ */
\f
#ifdef mips
#define MACHINE_TYPE "mips"
#define FASL_INTERNAL_FORMAT FASL_MIPS
-#define TYPE_CODE_LENGTH 6
#define FLOATING_ALIGNMENT 0x7
#if defined(_IRIX6) && defined(HAS_COMPILER_SUPPORT) && !defined(NATIVE_CODE_IS_C)
#if _ISP__M68K
#define MACHINE_TYPE "Apollo 68k"
#define FASL_INTERNAL_FORMAT FASL_APOLLO_68K
-#define TYPE_CODE_LENGTH 6
#else
#define MACHINE_TYPE "Apollo Prism"
#define FASL_INTERNAL_FORMAT FASL_APOLLO_PRISM
#define MAX_FLONUM_EXPONENT 1023
#endif
\f
+#ifdef __ppc__
+#define MACHINE_TYPE "PowerPC-32"
+#define FASL_INTERNAL_FORMAT FASL_PPC32
+#define FLOATING_ALIGNMENT 0x7
+#endif
+
+#ifdef __ppc64__
+#define MACHINE_TYPE "PowerPC-64"
+#define FASL_INTERNAL_FORMAT FASL_PPC64
+#endif
+
+#ifdef __x86_64__
+#define MACHINE_TYPE "x86-64"
+#define FASL_INTERNAL_FORMAT FASL_X86_64
+#endif
+
+#ifdef __ia64__
+#define MACHINE_TYPE "ia64"
+#define FASL_INTERNAL_FORMAT FASL_IA64
+#endif
+\f
#ifdef NATIVE_CODE_IS_C
# ifndef HAS_COMPILER_SUPPORT
# define HAS_COMPILER_SUPPORT
# endif
-# ifndef TYPE_CODE_LENGTH
-# define TYPE_CODE_LENGTH 6
-# endif
#endif
/* Make sure that some definition applies. If this error occurs, and
#endif
#ifndef TYPE_CODE_LENGTH
-# define TYPE_CODE_LENGTH 8
+# define TYPE_CODE_LENGTH 6
#endif
/* The GNU C compiler does not have any of these bugs. */
/* -*-C-*-
-$Id: error.c,v 1.9 2003/02/14 18:28:18 cph Exp $
+$Id: error.c,v 1.10 2006/09/16 11:19:09 gjr Exp $
-Copyright (C) 1990-2000 Massachusetts Institute of Technology
+Copyright (C) 1990-2000, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
static PTR
DEFUN (xmalloc, (length), unsigned int length)
{
+#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
+#else
extern PTR EXFUN (malloc, (unsigned int length));
+#endif
+
PTR result = (malloc (length));
if (result == 0)
{
/* -*-C-*-
-$Id: fasl.h,v 9.40 2003/02/14 18:28:18 cph Exp $
+$Id: fasl.h,v 9.41 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1987-1999 Massachusetts Institute of Technology
+Copyright (c) 1987-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
/* FASL Version */
-#define FASL_FILE_MARKER 0xFAFAFAFA
+#if (SIZEOF_UNSIGNED_LONG == 8)
+#define FASL_FILE_MARKER 0xFAFAFAFAFAFAFAFAULL
+#else
+#define FASL_FILE_MARKER 0xFAFAFAFAUL
+#endif
/* The FASL file has a header which begins as follows: */
/* -*-C-*-
-$Id: history.h,v 9.33 2003/02/14 18:28:19 cph Exp $
+$Id: history.h,v 9.34 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1987-1990, 1999, 2002 Massachusetts Institute of Technology
+Copyright (c) 1987-1990, 1999, 2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#define RIB_MARK 2
#define HISTORY_MARK_TYPE (UNMARKED_HISTORY_TYPE ^ MARKED_HISTORY_TYPE)
-#define HISTORY_MARK_MASK (HISTORY_MARK_TYPE << DATUM_LENGTH)
+#define HISTORY_MARK_MASK (((unsigned long) HISTORY_MARK_TYPE) << DATUM_LENGTH)
#if ((UNMARKED_HISTORY_TYPE | HISTORY_MARK_TYPE) != MARKED_HISTORY_TYPE)
#include "error: Bad history types in types.h and history.h"
/* -*-C-*-
-$Id: liarc.h,v 1.21 2003/02/14 18:28:19 cph Exp $
+$Id: liarc.h,v 1.22 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1992-2002 Massachusetts Institute of Technology
+Copyright (c) 1992-2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#ifndef MIT_SCHEME
#define MIT_SCHEME
#endif
-
-#ifndef NATIVE_CODE_IS_C
-#define NATIVE_CODE_IS_C
-#endif
\f
#include <stdio.h>
#include "config.h"
#include "prim.h"
#include "cmpgc.h"
#include "cmpintmd.h"
+#include "trap.h"
+#include "outf.h"
+#include "extern.h"
#ifdef __STDC__
# define USE_STDARG
# include <varargs.h>
#endif /* __STDC__ */
+#ifdef __GNUC__
+/* Add attributes to avoid warnings from -Wall for unreferenced labels */
+# define DEFLABEL(name) name : __attribute__((unused))
+#else /* not __GNUC__ */
+# define DEFLABEL(name) name :
+#endif /* __GNUC__ */
+
/* #define USE_GLOBAL_VARIABLES */
+
+#ifdef LIARC_IN_MICROCODE
+#define USE_GLOBAL_VARIABLES
+#endif
+
#define USE_SHORTCKT_JUMP
extern PTR dstack_position;
};
typedef union machine_word_u machine_word;
+
+typedef unsigned long entry_count_t;
\f
#define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT))
#define ADDRESS_UNITS_PER_FLOAT (sizeof (double))
(MEMORY_TO_STRING ((len), (unsigned char *) str))
#define C_SYM_INTERN(len,str) \
- (MEMORY_TO_SYMBOL ((len), ((unsigned char *) str)))
+ (MEMORY_TO_SYMBOL ((len), ((CONST char *) str)))
#define MAKE_PRIMITIVE_PROCEDURE(name,arity) (MAKE_PRIMITIVE (name, arity))
#define Rrb Registers
#define Rsp sp_register
-#define DECLARE_VARIABLES() int unsed_variable_to_keep_C_happy
+#define DECLARE_VARIABLES() int unused_variable_to_keep_C_happy
#define UNCACHE_VARIABLES() do {} while (0)
#define CACHE_VARIABLES() do {} while (0)
#define Rrb Registers
+#ifdef HEAP_IN_LOW_MEMORY
+
#define DECLARE_VARIABLES() \
REGISTER SCHEME_OBJECT Rvl = val_register; \
REGISTER SCHEME_OBJECT * Rhp = Free; \
REGISTER SCHEME_OBJECT * Rsp = sp_register
+#define DECLARE_VARIABLES_FOR_DATA()
+
+#else
+
+#undef MEMBASE
+#define MEMBASE lcl_membase
+
+#define DECLARE_VARIABLES() \
+REGISTER SCHEME_OBJECT Rvl = val_register; \
+REGISTER SCHEME_OBJECT * Rhp = Free; \
+REGISTER SCHEME_OBJECT * Rsp = sp_register; \
+REGISTER SCHEME_OBJECT * lcl_membase = memory_base
+
+#define DECLARE_VARIABLES_FOR_DATA() \
+REGISTER SCHEME_OBJECT * lcl_membase = memory_base
+
+#endif
+
+#define DECLARE_VARIABLES_FOR_OBJECT()
+
+/* lcl_membase is not cached/uncached because it is a constant */
+
#define UNCACHE_VARIABLES() do \
{ \
sp_register = Rsp; \
\f
/* Linking and initialization */
+struct liarc_code_S
+{
+ const char * name;
+ entry_count_t nentries;
+ SCHEME_OBJECT * EXFUN ((* code), (SCHEME_OBJECT *, entry_count_t));
+};
+
+struct liarc_data_S
+{
+ const char * name;
+ SCHEME_OBJECT * EXFUN ((* data), (entry_count_t));
+};
+
#define DECLARE_SUBCODE(name, nentries, decl_code, code) do \
{ \
int result = (declare_compiled_code (name, nentries, \
return (result); \
} while (0)
+#define DECLARE_SUBCODE_MULTIPLE(code_array) do \
+{ \
+ int result = \
+ declare_compiled_code_mult (((sizeof (code_array)) \
+ / (sizeof (struct liarc_code_S))), \
+ (& code_array[0])); \
+ if (result != 0) \
+ return (result); \
+} while (0)
+
+#define DECLARE_SUBDATA_MULTIPLE(data_array) do \
+{ \
+ int result = \
+ declare_compiled_data_mult (((sizeof (data_array)) \
+ / (sizeof (struct liarc_data_S))), \
+ (& data_array[0])); \
+ if (result != 0) \
+ return (result); \
+} while (0)
+\f
#ifndef COMPILE_FOR_DYNAMIC_LOADING
/* This does nothing in the sources. */
# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
extern int EXFUN (decl_code, (void)); \
- extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long));
+ extern SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, entry_count_t));
# define DECLARE_COMPILED_DATA(name, decl_data, data) \
extern int EXFUN (decl_data, (void)); \
- extern SCHEME_OBJECT * EXFUN (data, (unsigned long));
+ extern SCHEME_OBJECT * EXFUN (data, (entry_count_t));
+
+# define DECLARE_DATA_OBJECT(name, data) \
+ extern SCHEME_OBJECT EXFUN (data, (void));
# define DECLARE_DYNAMIC_INITIALIZATION(name)
+# define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name)
+
#else /* COMPILE_FOR_DYNAMIC_LOADING */
# define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \
DEFUN_VOID (dload_initialize_code) \
{ \
int EXFUN (decl_code, (void)); \
- SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, unsigned long)); \
+ SCHEME_OBJECT * EXFUN (code, (SCHEME_OBJECT *, entry_count_t)); \
\
return (declare_compiled_code (name, nentries, \
decl_code, code)); \
DEFUN_VOID (dload_initialize_data) \
{ \
int EXFUN (decl_data, (void)); \
- SCHEME_OBJECT * EXFUN (data, (unsigned long)); \
+ SCHEME_OBJECT * EXFUN (data, (entry_count_t)); \
\
return (declare_compiled_data (name, decl_data, data)); \
}
+# define DECLARE_DATA_OBJECT(name, data) \
+ static int \
+ DEFUN_VOID (dload_initialize_data) \
+ { \
+ SCHEME_OBJECT EXFUN (data, (void)); \
+ \
+ return (declare_data_object (name, data)); \
+ }
+
+
# define DECLARE_DYNAMIC_INITIALIZATION(name) \
extern char * EXFUN (dload_initialize_file, (void)); \
\
return ((char *) NULL); \
else \
return (name); \
- } \
+ }
+
+# define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name) \
+ extern char * EXFUN (dload_initialize_file, (void)); \
+ \
+ char * \
+ DEFUN_VOID (dload_initialize_file) \
+ { \
+ int result = (dload_initialize_data ()); \
+ if (result != 0) \
+ return ((char *) NULL); \
+ else \
+ return (name); \
+ }
#endif /* COMPILE_FOR_DYNAMIC_LOADING */
\f
EXFUN (multiply_with_overflow, (long, long, long *)),
EXFUN (declare_compiled_code,
(char *,
- unsigned long,
+ entry_count_t,
int EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, unsigned long)))),
+ SCHEME_OBJECT * EXFUN ((*), (SCHEME_OBJECT *, entry_count_t)))),
EXFUN (declare_compiled_data,
(char *,
int EXFUN ((*), (void)),
- SCHEME_OBJECT * EXFUN ((*), (unsigned long)))),
+ SCHEME_OBJECT * EXFUN ((*), (entry_count_t)))),
+ EXFUN (declare_data_object,
+ (char *,
+ SCHEME_OBJECT EXFUN ((*), (void)))),
+ EXFUN (declare_compiled_code_mult, (unsigned, CONST struct liarc_code_S *)),
+ EXFUN (declare_compiled_data_mult, (unsigned, CONST struct liarc_data_S *)),
EXFUN (NO_SUBBLOCKS, (void));
extern SCHEME_OBJECT
EXFUN (initialize_subblock, (char *)),
- * EXFUN (invoke_utility, (int, long, long, long, long));
+ * EXFUN (invoke_utility, (int, long, long, long, long)),
+ EXFUN (unstackify, (unsigned char * prog, entry_count_t dispatch_base));
extern double
EXFUN (acos, (double)),
#ifndef BUG_GCC_LONG_CALLS
-extern SCHEME_OBJECT EXFUN (memory_to_string, (long, unsigned char *));
-extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_string,
+ (unsigned long, CONST unsigned char *));
+extern SCHEME_OBJECT EXFUN (memory_to_symbol, (unsigned long, CONST char *));
extern SCHEME_OBJECT EXFUN (make_vector, (long, SCHEME_OBJECT, Boolean));
extern SCHEME_OBJECT EXFUN (cons, (SCHEME_OBJECT, SCHEME_OBJECT));
extern SCHEME_OBJECT EXFUN (double_to_flonum, (double));
extern SCHEME_OBJECT EXFUN (long_to_integer, (long));
-extern SCHEME_OBJECT EXFUN (digit_string_to_integer, (Boolean, long, char *));
-extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string, (long, long, char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_integer,
+ (Boolean, unsigned long, unsigned char *));
+extern SCHEME_OBJECT EXFUN (digit_string_to_bit_string,
+ (unsigned long, unsigned long, unsigned char *));
extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
+extern SCHEME_OBJECT EXFUN (memory_to_uninterned_symbol,
+ (unsigned long, unsigned char *));
#define MEMORY_TO_STRING memory_to_string
-#define MEMORY_TO_SYMBOL memory_to_symbol
-#define MAKE_VECTOR make_vector
+#define MEMORY_TO_SYMBOL(len,str) memory_to_symbol (len, str)
+#define MAKE_VECTOR(len,init,flag) make_vector (((long) len), init, flag)
#define CONS cons
#define RCONSM rconsm
#define DOUBLE_TO_FLONUM double_to_flonum
#define LONG_TO_INTEGER long_to_integer
-#define DIGIT_STRING_TO_INTEGER digit_string_to_integer
-#define DIGIT_STRING_TO_BIT_STRING digit_string_to_bit_string
-#define MAKE_PRIMITIVE make_primitive
+#define DIGIT_STRING_TO_INTEGER(sgn,len,str) \
+ digit_string_to_integer(sgn, ((unsigned long) len), ((unsigned char *) str))
+#define DIGIT_STRING_TO_BIT_STRING(blen,len,str) \
+ digit_string_to_bit_string(((unsigned long) blen), \
+ ((unsigned long) len), \
+ ((unsigned char *) str))
+#define MAKE_PRIMITIVE(str,arity) \
+ make_primitive (((char *) str), ((int) arity))
+#define C_TO_UNINTERNED_SYMBOL memory_to_uninterned_symbol
#else /* GCC on Spectrum has a strange bug so do thing differently .... */
-extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ());
+extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [11])), ());
#define MEMORY_TO_STRING \
- ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) \
+ ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned char *))) \
(constructor_kludge[0]))
#define MEMORY_TO_SYMBOL \
- ((SCHEME_OBJECT EXFUN ((*), (long, unsigned char *))) \
+ ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned char *))) \
(constructor_kludge[1]))
#define MAKE_VECTOR \
- ((SCHEME_OBJECT EXFUN ((*), (long, SCHEME_OBJECT, Boolean))) \
+ ((SCHEME_OBJECT EXFUN ((*), (unsigned long, SCHEME_OBJECT, Boolean))) \
(constructor_kludge[2]))
#define CONS \
((SCHEME_OBJECT EXFUN ((*), (long))) (constructor_kludge[6]))
#define DIGIT_STRING_TO_INTEGER \
- ((SCHEME_OBJECT EXFUN ((*), (Boolean, long, char *))) \
+ ((SCHEME_OBJECT EXFUN ((*), (Boolean, unsigned long, char *))) \
(constructor_kludge[7]))
#define DIGIT_STRING_TO_BIT_STRING \
- ((SCHEME_OBJECT EXFUN ((*), (long, long, char *))) \
+ ((SCHEME_OBJECT EXFUN ((*), (unsigned long, unsigned long, char *))) \
(constructor_kludge[8]))
#define MAKE_PRIMITIVE \
((SCHEME_OBJECT EXFUN ((*), (char *, int))) (constructor_kludge[9]))
+#define C_TO_UNINTERNED_SYMBOL \
+ ((SCHEME_OBJECT EXFUN ((*), (unsigned long, char *))) \
+ (constructor_kludge[10]))
+
#endif /* BUG_GCC_LONG_CALLS */
#endif /* LIARC_INCLUDED */
# -*- Makefile -*-
#
-# $Id: Makefile.in.in,v 1.29 2006/06/10 05:38:02 cph Exp $
+# $Id: Makefile.in.in,v 1.30 2006/09/16 11:19:09 gjr Exp $
#
# Copyright 2000,2001,2002,2003,2005,2006 Massachusetts Institute of Technology
#
# **** END BOILERPLATE ****
+# **** C back end stuff (I) ****
+
+COMPILED_DEFS = @COMPILED_DEFS@
+
+COMPILED_SOURCES = @(write-compiled "files-compiled")@
+
+COMPILED_OBJECTS = $(COMPILED_SOURCES:.c=.o)
+
+COMPILED_SOURCES_1 = @COMPILED_SOURCES_1@
+
+COMPILED_OBJECTS_1 = @COMPILED_OBJECTS_1@
+
+# **** End C back end stuff (I) ***
+
# **** Tool configuration ****
AUXDIR = $(libdir)/mit-scheme
GZIP_ENV = --best
DEFS = -DMIT_SCHEME -DDEFAULT_LIBRARY_PATH=\"$(AUXDIR)\" @DEFS@ \
- @SCHEME_DEFS@ -I. -I$(srcdir) -I.
+ $(COMPILED_DEFS) @SCHEME_DEFS@ -I. -I$(srcdir) -I.
CFLAGS = @CFLAGS@
X_CFLAGS = @X_CFLAGS@
CPPFLAGS = @CPPFLAGS@
# **** Configured files ****
GC_HEAD_FILES = @GC_HEAD_FILES@
-OPTIONAL_SOURCES = @OPTIONAL_SOURCES@
-OPTIONAL_OBJECTS = @OPTIONAL_OBJECTS@
+OPTIONAL_SOURCES = @OPTIONAL_SOURCES@ $(COMPILED_SOURCES_1)
+OPTIONAL_OBJECTS = @OPTIONAL_OBJECTS@ $(COMPILED_OBJECTS_1)
STATIC_LIBS = @STATIC_PREFIX@ @STATIC_LIBS@ @STATIC_SUFFIX@
X_LIBS = @X_PRE_LIBS@ @LIB_X11@ @X_EXTRA_LIBS@
PRBFISH_LIBS = @PRBFISH_LIBS@
CLEAN_FILES = $(ALL_PROGRAMS) $(ALL_LIBS) $(ALL_DATA) $(EXTRA_PROGRAMS)
DISTCLEAN_FILES = Makefile config.h config.cache config.log config.status \
- cmpauxmd.m4 cmpintmd.h TAGS makegen-cc
+ cmpauxmd.m4 cmpauxmd.c cmpintmd.h TAGS makegen-cc
MAINTAINER_CLEAN_FILES = Makefile.in Makefile.deps config.h.in configure
.SUFFIXES: .c .o .s .m4
.c.o:
- $(COMPILE) -c $*.c
+ $(COMPILE) -o $*.o -c $*.c
.m4.s:
$(EXPAND) $*.m4 > $*.s
-rm -f $@
$(LINK) $(scheme_LDFLAGS) $(scheme_OBJECTS) $(scheme_LIBS)
-usrdef.c: $(SHARED_SOURCES) $(STD_GC_SOURCES) findprim
+usrdef.c: $(SHARED_SOURCES) $(STD_GC_SOURCES) findprim Makefile
-rm -f $@
./findprim $(SHARED_SOURCES) $(STD_GC_SOURCES) > usrdef.c
-rm -f $@
$(LINK) $(bchscheme_LDFLAGS) $(bchscheme_OBJECTS) $(bchscheme_LIBS)
-bchdef.c: $(SHARED_SOURCES) $(BCH_GC_SOURCES) findprim
+bchdef.c: $(SHARED_SOURCES) $(BCH_GC_SOURCES) findprim Makefile
-rm -f $@
./findprim $(SHARED_SOURCES) $(BCH_GC_SOURCES) > bchdef.c
@(write-dependencies)@
+# **** C back end stuff (II) ****
+
+@CMPAUXMDO@ : cmpauxmd.c liarc.tch prims.h bignum.h bitstr.h avltree.h \
+ outf.h extern.h
+
+compinit.o : compinit.c compinit.h liarc.tch
+
+unstackify.o: unstackify.c stackops.h liarc.tch
+
+LIARC_HEAD_FILES = \
+ansidecl.h \
+config.h \
+dstack.h \
+default.h \
+object.h \
+sdata.h \
+types.h \
+errors.h \
+const.h \
+interp.h \
+prim.h \
+trap.h \
+outf.h \
+extern.h \
+$(GC_HEAD_FILES)
+
+#/* The following includes liarc.tch in case COMPILED_SOURCES is empty,
+# to prevent fgrep from reading stdin.
+# */
+compinit.h : $(COMPILED_SOURCES) liarc.tch Makefile
+ @echo "#*** Generating" $@ "because of" $?
+ rm -f $@
+ grep -E \^DECLARE_COMPILED_CODE liarc.tch $(COMPILED_SOURCES) | \
+ sed -e 's/.*:/ /' -e 's/)/);/' > $@
+ grep -E \^DECLARE_COMPILED_DATA liarc.tch $(COMPILED_SOURCES) | \
+ sed -e 's/.*:/ /' -e 's/)/);/' >> $@
+ grep -E \^DECLARE_DATA_OBJECT liarc.tch $(COMPILED_SOURCES) | \
+ sed -e 's/.*:/ /' -e 's/)/);/' >> $@
+
+foo $(COMPILED_OBJECTS) : liarc.tch
+liarc.tch: liarc.h $(LIARC_HEAD_FILES)
+ @echo "#** Generating" $@ because of $?
+ rm -f $@
+ echo "touch" > $@
+
+# **** End C back end stuff (II) ***
+
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: files-compiled.scm,v 1.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; Unix-specific C files.
+
+"utabmd.c"
+"../runtime/*.c"
+"../sf/*.c"
+"../cref/*.c"
+"../compiler/*.c"
+"../compiler/back/*.c"
+"../compiler/base/*.c"
+"../compiler/fggen/*.c"
+"../compiler/fgopt/*.c"
+"../compiler/machines/C/*.c"
+"../compiler/rtlbase/*.c"
+"../compiler/rtlgen/*.c"
+"../compiler/rtlopt/*.c"
+"../star-parser/*.c"
#| -*-Scheme-*-
-$Id: makegen.scm,v 1.9 2006/06/10 05:24:54 cph Exp $
+$Id: makegen.scm,v 1.10 2006/09/16 11:19:09 gjr Exp $
Copyright 2000,2001,2003,2005,2006 Massachusetts Institute of Technology
((WRITE-DEPENDENCIES)
(guarantee-nargs 0)
(write-dependencies file-lists deps-filename output))
+ ((WRITE-COMPILED)
+ (guarantee-nargs 1)
+ (let ((entry (assoc (cadr command) file-lists)))
+ (if (not entry)
+ (malformed))
+ (write-items (append-map (lambda (entry)
+ (map enough-namestring
+ (directory-read entry)))
+ (cdr entry))
+ column
+ output)
+ 0))
(else
(error "Unknown command:" command)))))))
\f
(maybe-update-dependencies
deps-filename
(sort (append-map (lambda (file-list)
- (map (lambda (base) (string-append base ".c"))
- (cdr file-list)))
+ (if (string=? (car file-list) "files-compiled")
+ '()
+ (map (lambda (base) (string-append base ".c"))
+ (cdr file-list))))
file-lists)
string<?))
(call-with-input-file deps-filename
/* -*-C-*-
-$Id: memmag.c,v 9.71 2003/02/14 18:28:20 cph Exp $
+$Id: memmag.c,v 9.72 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1987-2000, 2002 Massachusetts Institute of Technology
+Copyright (c) 1987-2000, 2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#include "prims.h"
#include "memmag.h"
#include "gccode.h"
+#include "os.h"
/* Imports */
/* -*-C-*-
-$Id: nttop.c,v 1.36 2006/01/29 06:37:30 cph Exp $
+$Id: nttop.c,v 1.37 2006/09/16 11:19:09 gjr Exp $
Copyright 1993,1997,1998,2000,2003,2004 Massachusetts Institute of Technology
Copyright 2006 Massachusetts Institute of Technology
}
#endif
+/* This is called during initialization, when the error system is not
+ set up.
+*/
+
+void *
+OS_malloc_init (unsigned int size)
+{
+ void * result = (malloc (size));
+ return (result);
+}
+
void *
OS_malloc (unsigned int size)
{
/* -*-C-*-
-$Id: object.h,v 9.59 2005/07/24 05:10:03 cph Exp $
+$Id: object.h,v 9.60 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
Copyright 1993,1995,1997,1998,2000,2001 Massachusetts Institute of Technology
-Copyright 2003,2005 Massachusetts Institute of Technology
+Copyright 2003,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
/* Machine dependencies */
#ifndef HEAP_MALLOC
-# define HEAP_MALLOC OS_malloc
+# define HEAP_MALLOC OS_malloc_init
#endif
#ifdef HEAP_IN_LOW_MEMORY /* Storing absolute addresses */
(high) = (memory_base + _space); \
} while (0)
+#define MEMBASE memory_base
+
+/* These use the MEMBASE macro so that C-compiled code can cache
+ memory_base locally and use the local version.
+*/
+
#ifndef DATUM_TO_ADDRESS
-# define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + memory_base))
+# define DATUM_TO_ADDRESS(datum) ((SCHEME_OBJECT *) ((datum) + MEMBASE))
#endif
#ifndef ADDRESS_TO_DATUM
-# define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) ((address) - memory_base))
+# define ADDRESS_TO_DATUM(address) ((SCHEME_OBJECT) ((address) - MEMBASE))
#endif
#endif /* HEAP_IN_LOW_MEMORY */
#define MAKE_CHAR(bucky_bits, code) \
(MAKE_OBJECT \
(TC_CHARACTER, \
- (((unsigned long) (bucky_bits)) << (CODE_LENGTH)) | (code)))
+ (((unsigned long) (bucky_bits)) << (CODE_LENGTH)) \
+ | ((unsigned long) (code))))
#define CHAR_BITS(chr) \
((((unsigned long) (OBJECT_DATUM (chr))) >> CODE_LENGTH) & CHAR_MASK_BITS)
/* -*-C-*-
-$Id: option.c,v 1.61 2003/03/21 17:28:25 cph Exp $
+$Id: option.c,v 1.62 2006/09/16 11:19:09 gjr Exp $
Copyright 1990,1991,1992,1993,1994,1995 Massachusetts Institute of Technology
Copyright 1996,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
-Copyright 2002,2003 Massachusetts Institute of Technology
+Copyright 2002,2003,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
CONST char * filename AND
SCHEME_OBJECT * header)
{
+ int result = 1;
+
#ifdef __WIN32__
HANDLE handle
DWORD bytes_read;
if (handle == INVALID_HANDLE_VALUE)
return (0);
+
if (! ((ReadFile (handle, header, bytes_to_read, (&bytes_read), 0))
&& (bytes_read == bytes_to_read)))
- {
- CloseHandle (handle);
- return (0);
- }
+ result = 0;
+
CloseHandle (handle);
- return (1);
#else /* not __WIN32__ */
return (0);
if ((fread (header, (sizeof (SCHEME_OBJECT)), FASL_HEADER_LENGTH, stream))
!= FASL_HEADER_LENGTH)
- {
- fclose (stream);
- return (0);
- }
+ result = 0;
+
fclose (stream);
- return (1);
#endif /* not __WIN32__ */
+
+ /* Note: This is an approximation to whether the file can be loaded
+ as a band.
+ Mostly it catches wrong-format files (e.g. bands for another arch.)
+ */
+
+ if (((header[FASL_Offset_Marker]) != FASL_FILE_MARKER)
+ || ((The_Version (header[FASL_Offset_Version])) != FASL_READ_VERSION)
+ || ((The_Machine_Type (header[FASL_Offset_Version]))
+ != FASL_INTERNAL_FORMAT))
+ result = 0;
+
+ return (result);
}
static int
CONST char ** argv)
{
int band_sizes_valid = 0;
+ int fail_fasl_if_no_utab = 0;
unsigned long band_constant_size;
unsigned long band_heap_size;
(option_large_sizes
? DEFAULT_LARGE_STACK
: DEFAULT_SMALL_STACK)));
+
+ fail_fasl_if_no_utab = (option_fasl_file != 0);
+
if (option_utabmd_file != 0)
xfree (option_utabmd_file);
if (option_raw_utabmd != 0)
option_raw_utabmd,
UTABMD_FILE_VARIABLE,
DEFAULT_UTABMD_FILE,
- (option_fasl_file != 0)));
+ fail_fasl_if_no_utab));
}
else
+ {
+#ifdef NATIVE_CODE_IS_C
+ /* FIXME: This should check if we have "microcode_utabmd" compiled */
+ fail_fasl_if_no_utab = 0;
+#endif
+
option_utabmd_file =
(standard_filename_option ("utab",
option_raw_utab,
UTABMD_FILE_VARIABLE,
DEFAULT_UTABMD_FILE,
- (option_fasl_file != 0)));
+ fail_fasl_if_no_utab));
+ }
/* These are only meaningful for bchscheme. */
/* -*-C-*-
-$Id: os.h,v 1.9 2003/02/14 18:28:22 cph Exp $
+$Id: os.h,v 1.10 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1990-2000 Massachusetts Institute of Technology
+Copyright (c) 1990-2000, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
typedef unsigned int Tchannel;
+extern PTR EXFUN (OS_malloc_init, (unsigned int));
extern PTR EXFUN (OS_malloc, (unsigned int));
extern PTR EXFUN (OS_realloc, (PTR, unsigned int));
extern void EXFUN (OS_free, (PTR));
/* -*-C-*-
-$Id: os2.c,v 1.10 2003/02/14 18:28:22 cph Exp $
+$Id: os2.c,v 1.11 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1994-1999 Massachusetts Institute of Technology
+Copyright (c) 1994-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#endif /* not OS2_USE_SUBHEAP_MALLOC */
+/* This is called during initialization, when the error system is not
+ set up.
+*/
+
+void *
+OS_malloc_init (unsigned int size)
+{
+ void * result = (OS2_malloc_noerror (size));
+ return (result);
+}
+
void *
OS_malloc (unsigned int size)
{
/* -*-C-*-
-$Id: ppband.c,v 9.65 2006/06/10 05:24:54 cph Exp $
+$Id: ppband.c,v 9.66 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology
Copyright 1993,1999,2000,2006 Massachusetts Institute of Technology
# if (SIZEOF_UNSIGNED_LONG == 4) /* 32-bit word versions */
# define UNSIGNED_LONG_HIGH_HALF(unsigned_long) ((unsigned_long) >> 16)
# define UNSIGNED_LONG_LOW_HALF(unsigned_long) ((unsigned_long) & 0xFFFF)
+# elif (SIZEOF_UNSIGNED_LONG == 8) /* 32-bit word versions */
+# define UNSIGNED_LONG_HIGH_HALF(unsigned_long) ((unsigned_long) >> 32)
+# define UNSIGNED_LONG_LOW_HALF(unsigned_long) ((unsigned_long) & 0xFFFFFFFF)
# else
-# error "`ppband' assumes that (SIZEOF_UNSIGNED_LONG == 4) is true."
+# error "Unexpected SIZEOF_UNSIGNED_LONG for ppband."
# endif
#else
# error "`ppband' assumes that (CHAR_BIT == 8) is true."
# define Display_LOC_HILO_RAW_FORMAT_STRING "%7lx: "\
"[%04lx|%04lx] = "
# endif
+# elif (SIZEOF_UNSIGNED_LONG == 8)
+# define Display_LOC_TYPE_DAT_FORMAT_STRING "%7lx: %2lx|%15lx "
+# define Display_LOC_HILO_RAW_FORMAT_STRING "%7lx: "\
+ "[%08lx|%08lx] = "
# else
-# error "`ppband' assumes that (SIZEOF_UNSIGNED_LONG == 4) is true."
+# error "Unexpected SIZEOF_UNSIGNED_LONG for ppband."
# endif
#else
# error "`ppband' assumes that (CHAR_BIT == 8) is true."
/* -*-C-*-
-$Id: prim.c,v 9.45 2005/07/01 19:38:39 cph Exp $
+$Id: prim.c,v 9.46 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1992,1993 Massachusetts Institute of Technology
-Copyright 1996,2004,2005 Massachusetts Institute of Technology
+Copyright 1996,2004,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
- (ulong_to_integer (ADDRESS_TO_DATUM (arg_ulong_integer (1))));
+ (ulong_to_integer
+ (ADDRESS_TO_DATUM ((SCHEME_OBJECT *) (arg_ulong_integer (1)))));
}
\f
DEFINE_PRIMITIVE ("MAKE-NON-POINTER-OBJECT", Prim_make_non_ptr_object, 1, 1,
/* -*-C-*-
-$Id: primutl.c,v 9.80 2005/07/24 05:08:55 cph Exp $
+$Id: primutl.c,v 9.81 2006/09/16 11:19:09 gjr Exp $
-Copyright 1993,2000,2001,2004,2005 Massachusetts Institute of Technology
+Copyright 1993,2000,2001,2004,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
SCHEME_OBJECT
DEFUN (make_primitive, (name, arity), char * name AND int arity)
{
+ /* This copies the name (and probes twice) because unstackify'd
+ primitive name strings are ephemeral.
+ */
+
SCHEME_OBJECT result;
+ char * name_to_insert;
+ tree_node prim = (tree_lookup (prim_procedure_tree, name));
+
+ if (prim != ((tree_node) NULL))
+ name_to_insert = ((char *) (prim->name));
+ else
+ {
+ name_to_insert = ((char *) (malloc (1 + (strlen (name)))));
+ if (name_to_insert == ((char *) NULL))
+ error_in_system_call (syserr_not_enough_space, syscall_malloc);
+ strcpy (name_to_insert, name);
+ }
- result = (declare_primitive (name,
+ result = (declare_primitive (name_to_insert,
Prim_unimplemented,
arity,
arity,
/* -*-C-*-
-$Id: psbtobin.c,v 9.63 2006/08/28 16:58:26 cph Exp $
+$Id: psbtobin.c,v 9.64 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
Copyright 1992,1993,1994,2000,2001,2005 Massachusetts Institute of Technology
void
DEFUN (relocation_error, (addr), long addr)
{
- fprintf (stderr, "%s: Out of range address %d.\n",
+ fprintf (stderr, "%s: Out of range address %ld.\n",
program_name, addr);
inconsistency ();
/*NOTREACHED*/
VMS_BUG (base_type = 0);
VMS_BUG (base_datum = 0);
- fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ fscanf (portable_file, "%02lx %lx", &base_type, &base_datum);
temp = (Relocate (base_datum));
if (c_compiled_p)
entry_addr = &temp[The_Datum];
if (Portable_Version != PORTABLE_VERSION)
{
fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
- fprintf (stderr, "Portable File Version %4d\n", Portable_Version);
- fprintf (stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
+ fprintf (stderr, "Portable File Version %4ld\n", Portable_Version);
+ fprintf (stderr, "Expected: Version %4ld\n", PORTABLE_VERSION);
quit (1);
}
{
fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
fprintf (stderr,
- "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
+ "Portable File Version %4ld;"
+ " Binary Version %4d; Subversion %4ld\n",
Portable_Version, Version, Sub_Version);
fprintf (stderr,
"Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
else
fprintf (stderr, "%s: %s\n", program_name,
"Portable file contains \"unexpected\" non-marked vectors.");
- fprintf (stderr, "Machine specified in the portable file: %4d\n",
+ fprintf (stderr, "Machine specified in the portable file: %4ld\n",
Machine);
fprintf (stderr, "Machine Expected: %4d\n",
FASL_INTERNAL_FORMAT);
SCHEME_OBJECT
* primitive_table, * primitive_table_end,
* c_code_table, * c_code_table_end,
- * Dumped_Object;
+ * Dumped_Object = ((SCHEME_OBJECT *) NULL);
Boolean result;
long Size;
/* -*-C-*-
-$Id: ptrvec.c,v 1.5 2003/02/14 18:28:23 cph Exp $
+$Id: ptrvec.c,v 1.6 2006/09/16 11:19:09 gjr Exp $
-Copyright (C) 1990-1999 Massachusetts Institute of Technology
+Copyright (C) 1990-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#include "outf.h"
#include "dstack.h"
+#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
+#else
+extern PTR EXFUN (malloc, (unsigned int length));
+extern PTR EXFUN (realloc, (PTR ptr, unsigned int length));
+#endif
+
static PTR
DEFUN (xmalloc, (length), unsigned int length)
{
- extern PTR EXFUN (malloc, (unsigned int length));
PTR result = (malloc (length));
if (result == 0)
{
static PTR
DEFUN (xrealloc, (ptr, length), PTR ptr AND unsigned int length)
{
- extern PTR EXFUN (realloc, (PTR ptr, unsigned int length));
PTR result = (realloc (ptr, length));
if (result == 0)
{
--- /dev/null
+/* Emacs: this is -*- C -*- code. */
+
+#ifndef STACKOPS_H
+#define STACKOPS_H
+
+/*
+
+$Id: stackops.h,v 11.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+*/
+
+/* C code produced
+ Thursday August 24, 2006 at 6:20:11 PM
+ */
+
+typedef enum
+{
+ stackify_opcode_illegal = 0,
+ stackify_opcode_escape = 01,
+ stackify_opcode_push_Pfixnum = 02,
+ stackify_opcode_push__fixnum = 03,
+ stackify_opcode_push_Pinteger = 04,
+ stackify_opcode_push__integer = 05,
+ stackify_opcode_push_false = 06,
+ stackify_opcode_push_true = 07,
+ stackify_opcode_push_nil = 010,
+ stackify_opcode_push_flonum = 011,
+ stackify_opcode_push_cons_ratnum = 012,
+ stackify_opcode_push_cons_recnum = 013,
+ stackify_opcode_push_string = 014,
+ stackify_opcode_push_symbol = 015,
+ stackify_opcode_push_uninterned_symbol = 016,
+ stackify_opcode_push_char = 017,
+ stackify_opcode_push_bit_string = 020,
+ stackify_opcode_push_empty_cons = 021,
+ stackify_opcode_pop_and_set_car = 022,
+ stackify_opcode_pop_and_set_cdr = 023,
+ stackify_opcode_push_consS = 024,
+ stackify_opcode_push_empty_vector = 025,
+ stackify_opcode_pop_and_vector_set = 026,
+ stackify_opcode_push_vector = 027,
+ stackify_opcode_push_empty_record = 030,
+ stackify_opcode_pop_and_record_set = 031,
+ stackify_opcode_push_record = 032,
+ stackify_opcode_push_lookup = 033,
+ stackify_opcode_store = 034,
+ stackify_opcode_push_constant = 035,
+ stackify_opcode_push_unassigned = 036,
+ stackify_opcode_push_primitive = 037,
+ stackify_opcode_push_primitive_lexpr = 040,
+ stackify_opcode_push_nm_header = 041,
+ stackify_opcode_push_label_entry = 042,
+ stackify_opcode_push_linkage_header_operator = 043,
+ stackify_opcode_push_linkage_header_reference = 044,
+ stackify_opcode_push_linkage_header_assignment = 045,
+ stackify_opcode_push_linkage_header_global = 046,
+ stackify_opcode_push_linkage_header_closure = 047,
+ stackify_opcode_push_ulong = 050,
+ stackify_opcode_push_label_descriptor = 051,
+ stackify_opcode_cc_block_to_entry = 052,
+ stackify_opcode_retag_cc_block = 053,
+ stackify_opcode_push_return_code = 054,
+ stackify_opcode_push_0 = 0200,
+ stackify_opcode_push_1 = 0201,
+ stackify_opcode_push_2 = 0202,
+ stackify_opcode_push_3 = 0203,
+ stackify_opcode_push_4 = 0204,
+ stackify_opcode_push_5 = 0205,
+ stackify_opcode_push_6 = 0206,
+ stackify_opcode_push__1 = 0207,
+ stackify_opcode_push_consS_0 = 0210,
+ stackify_opcode_push_consS_1 = 0211,
+ stackify_opcode_push_consS_2 = 0212,
+ stackify_opcode_push_consS_3 = 0213,
+ stackify_opcode_push_consS_4 = 0214,
+ stackify_opcode_push_consS_5 = 0215,
+ stackify_opcode_push_consS_6 = 0216,
+ stackify_opcode_push_consS_7 = 0217,
+ stackify_opcode_pop_and_vector_set_0 = 0220,
+ stackify_opcode_pop_and_vector_set_1 = 0221,
+ stackify_opcode_pop_and_vector_set_2 = 0222,
+ stackify_opcode_pop_and_vector_set_3 = 0223,
+ stackify_opcode_pop_and_vector_set_4 = 0224,
+ stackify_opcode_pop_and_vector_set_5 = 0225,
+ stackify_opcode_pop_and_vector_set_6 = 0226,
+ stackify_opcode_pop_and_vector_set_7 = 0227,
+ stackify_opcode_push_vector_1 = 0230,
+ stackify_opcode_push_vector_2 = 0231,
+ stackify_opcode_push_vector_3 = 0232,
+ stackify_opcode_push_vector_4 = 0233,
+ stackify_opcode_push_vector_5 = 0234,
+ stackify_opcode_push_vector_6 = 0235,
+ stackify_opcode_push_vector_7 = 0236,
+ stackify_opcode_push_vector_8 = 0237,
+ stackify_opcode_pop_and_record_set_0 = 0240,
+ stackify_opcode_pop_and_record_set_1 = 0241,
+ stackify_opcode_pop_and_record_set_2 = 0242,
+ stackify_opcode_pop_and_record_set_3 = 0243,
+ stackify_opcode_pop_and_record_set_4 = 0244,
+ stackify_opcode_pop_and_record_set_5 = 0245,
+ stackify_opcode_pop_and_record_set_6 = 0246,
+ stackify_opcode_pop_and_record_set_7 = 0247,
+ stackify_opcode_push_record_1 = 0250,
+ stackify_opcode_push_record_2 = 0251,
+ stackify_opcode_push_record_3 = 0252,
+ stackify_opcode_push_record_4 = 0253,
+ stackify_opcode_push_record_5 = 0254,
+ stackify_opcode_push_record_6 = 0255,
+ stackify_opcode_push_record_7 = 0256,
+ stackify_opcode_push_record_8 = 0257,
+ stackify_opcode_push_lookup_0 = 0260,
+ stackify_opcode_push_lookup_1 = 0261,
+ stackify_opcode_push_lookup_2 = 0262,
+ stackify_opcode_push_lookup_3 = 0263,
+ stackify_opcode_push_lookup_4 = 0264,
+ stackify_opcode_push_lookup_5 = 0265,
+ stackify_opcode_push_lookup_6 = 0266,
+ stackify_opcode_push_lookup_7 = 0267,
+ stackify_opcode_store_0 = 0270,
+ stackify_opcode_store_1 = 0271,
+ stackify_opcode_store_2 = 0272,
+ stackify_opcode_store_3 = 0273,
+ stackify_opcode_store_4 = 0274,
+ stackify_opcode_store_5 = 0275,
+ stackify_opcode_store_6 = 0276,
+ stackify_opcode_store_7 = 0277,
+ stackify_opcode_push_primitive_0 = 0300,
+ stackify_opcode_push_primitive_1 = 0301,
+ stackify_opcode_push_primitive_2 = 0302,
+ stackify_opcode_push_primitive_3 = 0303,
+ stackify_opcode_push_primitive_4 = 0304,
+ stackify_opcode_push_primitive_5 = 0305,
+ stackify_opcode_push_primitive_6 = 0306,
+ stackify_opcode_push_primitive_7 = 0307,
+ N_STACKIFY_OPCODE = 200
+} stackify_opcode_t;
+
+#endif /* STACKOPS_H */
/* -*-C-*-
-$Id: tterm.c,v 1.16 2003/02/14 18:28:24 cph Exp $
+$Id: tterm.c,v 1.17 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1990-2002 Massachusetts Institute of Technology
+Copyright (c) 1990-2002, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
PRIMITIVE_HEADER (5);
{
char s [4096];
+#if defined(__netbsd__)
+ PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) NULL));
+#else
(void) tparam
((STRING_ARG (1)), s, (sizeof (s)),
(arg_nonnegative_integer (2)),
(arg_nonnegative_integer (4)),
(arg_nonnegative_integer (5)));
PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) s));
+#endif
}
}
--- /dev/null
+/* -*-C-*-
+
+$Id: unstackify.c,v 11.1 2006/09/16 11:19:09 gjr Exp $
+
+Copyright (c) 2006 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+*/
+
+#include <string.h>
+#include <stdlib.h>
+#define LIARC_IN_MICROCODE
+#include "liarc.h"
+#include "stackops.h"
+
+#ifndef DEBUG_STACKIFY
+
+#define DEBUG(stmt) do { } while (0)
+#define CHECK_SP_UNDERFLOW() do { } while (0)
+#define CHECK_SP_OVERFLOW() do { } while (0)
+#define CHECK_STR_OVERRUN() do { } while (0)
+\f
+#else /* DEBUG_STACKIFY */
+
+#define DEBUG(stmt) do { if (debug_flag) stmt } while (0)
+
+static char * opcode_names[] =
+{
+ "stackify-opcode/illegal",
+ "stackify-opcode/escape",
+ "stackify-opcode/push-+fixnum",
+ "stackify-opcode/push--fixnum",
+ "stackify-opcode/push-+integer",
+ "stackify-opcode/push--integer",
+ "stackify-opcode/push-false",
+ "stackify-opcode/push-true",
+ "stackify-opcode/push-nil",
+ "stackify-opcode/push-flonum",
+ "stackify-opcode/push-cons-ratnum",
+ "stackify-opcode/push-cons-recnum",
+ "stackify-opcode/push-string",
+ "stackify-opcode/push-symbol",
+ "stackify-opcode/push-uninterned-symbol",
+ "stackify-opcode/push-char",
+ "stackify-opcode/push-bit-string",
+ "stackify-opcode/push-empty-cons",
+ "stackify-opcode/pop-and-set-car",
+ "stackify-opcode/pop-and-set-cdr",
+ "stackify-opcode/push-cons*",
+ "stackify-opcode/push-empty-vector",
+ "stackify-opcode/pop-and-vector-set",
+ "stackify-opcode/push-vector",
+ "stackify-opcode/push-empty-record",
+ "stackify-opcode/pop-and-record-set",
+ "stackify-opcode/push-record",
+ "stackify-opcode/push-lookup",
+ "stackify-opcode/store",
+ "stackify-opcode/push-constant",
+ "stackify-opcode/push-unassigned",
+ "stackify-opcode/push-primitive",
+ "stackify-opcode/push-primitive-lexpr",
+ "stackify-opcode/push-nm-header",
+ "stackify-opcode/push-label-entry",
+ "stackify-opcode/push-linkage-header-operator",
+ "stackify-opcode/push-linkage-header-reference",
+ "stackify-opcode/push-linkage-header-assignment",
+ "stackify-opcode/push-linkage-header-global",
+ "stackify-opcode/push-linkage-header-closure",
+ "stackify-opcode/push-ulong",
+ "stackify-opcode/push-label-descriptor",
+ "stackify-opcode/cc-block-to-entry",
+ "stackify-opcode/retag-cc-block",
+ "stackify-opcode/push-return-code",
+ "unknown-055",
+ "unknown-056",
+ "unknown-057",
+ "unknown-060",
+ "unknown-061",
+ "unknown-062",
+ "unknown-063",
+ "unknown-064",
+ "unknown-065",
+ "unknown-066",
+ "unknown-067",
+ "unknown-070",
+ "unknown-071",
+ "unknown-072",
+ "unknown-073",
+ "unknown-074",
+ "unknown-075",
+ "unknown-076",
+ "unknown-077",
+ "unknown-0100",
+ "unknown-0101",
+ "unknown-0102",
+ "unknown-0103",
+ "unknown-0104",
+ "unknown-0105",
+ "unknown-0106",
+ "unknown-0107",
+ "unknown-0110",
+ "unknown-0111",
+ "unknown-0112",
+ "unknown-0113",
+ "unknown-0114",
+ "unknown-0115",
+ "unknown-0116",
+ "unknown-0117",
+ "unknown-0120",
+ "unknown-0121",
+ "unknown-0122",
+ "unknown-0123",
+ "unknown-0124",
+ "unknown-0125",
+ "unknown-0126",
+ "unknown-0127",
+ "unknown-0130",
+ "unknown-0131",
+ "unknown-0132",
+ "unknown-0133",
+ "unknown-0134",
+ "unknown-0135",
+ "unknown-0136",
+ "unknown-0137",
+ "unknown-0140",
+ "unknown-0141",
+ "unknown-0142",
+ "unknown-0143",
+ "unknown-0144",
+ "unknown-0145",
+ "unknown-0146",
+ "unknown-0147",
+ "unknown-0150",
+ "unknown-0151",
+ "unknown-0152",
+ "unknown-0153",
+ "unknown-0154",
+ "unknown-0155",
+ "unknown-0156",
+ "unknown-0157",
+ "unknown-0160",
+ "unknown-0161",
+ "unknown-0162",
+ "unknown-0163",
+ "unknown-0164",
+ "unknown-0165",
+ "unknown-0166",
+ "unknown-0167",
+ "unknown-0170",
+ "unknown-0171",
+ "unknown-0172",
+ "unknown-0173",
+ "unknown-0174",
+ "unknown-0175",
+ "unknown-0176",
+ "unknown-0177",
+ "stackify-opcode/push-0",
+ "stackify-opcode/push-1",
+ "stackify-opcode/push-2",
+ "stackify-opcode/push-3",
+ "stackify-opcode/push-4",
+ "stackify-opcode/push-5",
+ "stackify-opcode/push-6",
+ "stackify-opcode/push--1",
+ "stackify-opcode/push-cons*-0",
+ "stackify-opcode/push-cons*-1",
+ "stackify-opcode/push-cons*-2",
+ "stackify-opcode/push-cons*-3",
+ "stackify-opcode/push-cons*-4",
+ "stackify-opcode/push-cons*-5",
+ "stackify-opcode/push-cons*-6",
+ "stackify-opcode/push-cons*-7",
+ "stackify-opcode/pop-and-vector-set-0",
+ "stackify-opcode/pop-and-vector-set-1",
+ "stackify-opcode/pop-and-vector-set-2",
+ "stackify-opcode/pop-and-vector-set-3",
+ "stackify-opcode/pop-and-vector-set-4",
+ "stackify-opcode/pop-and-vector-set-5",
+ "stackify-opcode/pop-and-vector-set-6",
+ "stackify-opcode/pop-and-vector-set-7",
+ "stackify-opcode/push-vector-1",
+ "stackify-opcode/push-vector-2",
+ "stackify-opcode/push-vector-3",
+ "stackify-opcode/push-vector-4",
+ "stackify-opcode/push-vector-5",
+ "stackify-opcode/push-vector-6",
+ "stackify-opcode/push-vector-7",
+ "stackify-opcode/push-vector-8",
+ "stackify-opcode/pop-and-record-set-0",
+ "stackify-opcode/pop-and-record-set-1",
+ "stackify-opcode/pop-and-record-set-2",
+ "stackify-opcode/pop-and-record-set-3",
+ "stackify-opcode/pop-and-record-set-4",
+ "stackify-opcode/pop-and-record-set-5",
+ "stackify-opcode/pop-and-record-set-6",
+ "stackify-opcode/pop-and-record-set-7",
+ "stackify-opcode/push-record-1",
+ "stackify-opcode/push-record-2",
+ "stackify-opcode/push-record-3",
+ "stackify-opcode/push-record-4",
+ "stackify-opcode/push-record-5",
+ "stackify-opcode/push-record-6",
+ "stackify-opcode/push-record-7",
+ "stackify-opcode/push-record-8",
+ "stackify-opcode/push-lookup-0",
+ "stackify-opcode/push-lookup-1",
+ "stackify-opcode/push-lookup-2",
+ "stackify-opcode/push-lookup-3",
+ "stackify-opcode/push-lookup-4",
+ "stackify-opcode/push-lookup-5",
+ "stackify-opcode/push-lookup-6",
+ "stackify-opcode/push-lookup-7",
+ "stackify-opcode/store-0",
+ "stackify-opcode/store-1",
+ "stackify-opcode/store-2",
+ "stackify-opcode/store-3",
+ "stackify-opcode/store-4",
+ "stackify-opcode/store-5",
+ "stackify-opcode/store-6",
+ "stackify-opcode/store-7",
+ "stackify-opcode/push-primitive-0",
+ "stackify-opcode/push-primitive-1",
+ "stackify-opcode/push-primitive-2",
+ "stackify-opcode/push-primitive-3",
+ "stackify-opcode/push-primitive-4",
+ "stackify-opcode/push-primitive-5",
+ "stackify-opcode/push-primitive-6",
+ "stackify-opcode/push-primitive-7",
+ "unknown-0310",
+ "unknown-0311",
+ "unknown-0312",
+ "unknown-0313",
+ "unknown-0314",
+ "unknown-0315",
+ "unknown-0316",
+ "unknown-0317",
+ "unknown-0320",
+ "unknown-0321",
+ "unknown-0322",
+ "unknown-0323",
+ "unknown-0324",
+ "unknown-0325",
+ "unknown-0326",
+ "unknown-0327",
+ "unknown-0330",
+ "unknown-0331",
+ "unknown-0332",
+ "unknown-0333",
+ "unknown-0334",
+ "unknown-0335",
+ "unknown-0336",
+ "unknown-0337",
+ "unknown-0340",
+ "unknown-0341",
+ "unknown-0342",
+ "unknown-0343",
+ "unknown-0344",
+ "unknown-0345",
+ "unknown-0346",
+ "unknown-0347",
+ "unknown-0350",
+ "unknown-0351",
+ "unknown-0352",
+ "unknown-0353",
+ "unknown-0354",
+ "unknown-0355",
+ "unknown-0356",
+ "unknown-0357",
+ "unknown-0360",
+ "unknown-0361",
+ "unknown-0362",
+ "unknown-0363",
+ "unknown-0364",
+ "unknown-0365",
+ "unknown-0366",
+ "unknown-0367",
+ "unknown-0370",
+ "unknown-0371",
+ "unknown-0372",
+ "unknown-0373",
+ "unknown-0374",
+ "unknown-0375",
+ "unknown-0376",
+ "unknown-0377",
+};
+
+#define CHECK_SP_UNDERFLOW() do \
+{ \
+ if (sp > regmap) \
+ abort (); \
+} while (0)
+
+#define CHECK_SP_OVERFLOW() do \
+{ \
+ if (sp < stack_bot) \
+ abort (); \
+} while (0)
+
+#define CHECK_STR_OVERRUN() do \
+{ \
+ if (strptr > strptr_end) \
+ abort (); \
+} while (0)
+
+int debug_flag = 0;
+
+static unsigned char * pc_start;
+static SCHEME_OBJECT * stack_bot;
+static unsigned char * strptr_end;
+static unsigned char * strptr_start;
+
+static unsigned print_everything_count = 0;
+
+#endif /* DEBUG_STACKIFY */
+\f
+typedef struct stackify_context_S
+{
+ unsigned char * strptr;
+ entry_count_t dispatch_base;
+ SCHEME_OBJECT * sp;
+ SCHEME_OBJECT * regmap;
+} stackify_context_s, * stackify_context_t;
+
+static unsigned char * strptr;
+static entry_count_t dispatch_base;
+static SCHEME_OBJECT * sp, * regmap;
+
+#ifdef DEBUG_STACKIFY
+
+static void
+print_everything (stackify_opcode_t op, unsigned char * pc)
+{
+ if (print_everything_count == 0)
+ printf ("stack_bot = 0x%08x"
+ "; stack_base = 0x%08x"
+ "; strptr_end = 0x%08x\n",
+ ((unsigned) stack_bot),
+ ((unsigned) regmap),
+ ((unsigned) strptr_end));
+
+ printf ("(opcode %s stack-depth %d pc %d strtab-ptr %d)\n",
+ opcode_names[op],
+ (regmap - sp),
+ (pc - pc_start),
+ (strptr - strptr_start));
+ return;
+}
+
+#endif /* DEBUG_STACKIFY */
+
+static inline SCHEME_OBJECT
+DEFUN_VOID (unstackify_pop)
+{
+ SCHEME_OBJECT res = (* sp);
+
+ sp += 1;
+ CHECK_SP_UNDERFLOW ();
+ return (res);
+}
+
+static inline SCHEME_OBJECT
+DEFUN_VOID (unstackify_tos)
+{
+ return (* sp);
+}
+
+static inline void
+DEFUN (unstackify_push, (object), SCHEME_OBJECT object)
+{
+ sp -= 1;
+ CHECK_SP_OVERFLOW ();
+ (* sp) = object;
+ return;
+}
+\f
+/* Note: The encoded value is one greater than the actual value,
+ so that the encoding of a ulong never uses a null character.
+ Thus we subtract one after decoding.
+*/
+
+static unsigned long
+DEFUN_VOID (unstackify_read_ulong)
+{
+ unsigned shift = 0;
+ unsigned long value = 0;
+ unsigned char byte, * ptr = strptr;
+
+ CHECK_STR_OVERRUN ();
+
+ do
+ {
+ byte = (* ptr++);
+ value = (value | ((byte & 0x7f) << shift));
+ shift += 7;
+ } while ((byte & 0x80) != 0);
+
+ strptr = ptr;
+ return (value - 1);
+}
+
+static unsigned char *
+DEFUN (unstackify_read_string, (plen), unsigned long * plen)
+{
+ unsigned long len;
+ unsigned char * res;
+
+ len = (unstackify_read_ulong ());
+ res = strptr;
+ strptr = (res + len);
+ (* plen) = len;
+ return (res);
+}
+
+/* This returns a newly allocated string */
+
+static char *
+DEFUN_VOID (unstackify_read_C_string)
+{
+ char * str;
+ unsigned long len;
+ unsigned char * temp;
+
+ temp = (unstackify_read_string (& len));
+ str = ((char *) (malloc (len + 1)));
+ memcpy (str, temp, len);
+ str[len] = '\0';
+ return (str);
+}
+\f
+static void
+DEFUN (unstackify_push_consS, (N), unsigned long N)
+{
+ unsigned long i;
+ SCHEME_OBJECT kar, kdr;
+
+ kdr = (unstackify_pop ());
+ for (i = 0; (i <= N); i++)
+ {
+ kar = (unstackify_pop ());
+ kdr = (CONS (kar, kdr));
+ }
+
+ unstackify_push (kdr);
+}
+
+static void
+DEFUN (unstackify_pop_and_set_cXr, (N), unsigned long N)
+{
+ SCHEME_OBJECT cXr, pair;
+
+ cXr = (unstackify_pop ());
+ pair = (unstackify_tos ());
+ FAST_MEMORY_SET (pair, N, cXr);
+}
+
+static void
+DEFUN (unstackify_push_empty_vector, (N), unsigned long N)
+{
+ SCHEME_OBJECT res;
+
+ res = (ALLOCATE_VECTOR (N));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (unstackify_pop_and_vector_set, (N), unsigned long N)
+{
+ SCHEME_OBJECT el, vec;
+
+ el = (unstackify_pop ());
+ vec = (unstackify_tos ());
+ VECTOR_SET (vec, N, el);
+}
+
+static void
+DEFUN (unstackify_push_vector, (N), unsigned long N)
+{
+ unsigned long i;
+ SCHEME_OBJECT el, vec;
+
+ vec = (ALLOCATE_VECTOR (N));
+ for (i = 0; (i < N); i++)
+ {
+ el = (unstackify_pop ());
+ VECTOR_SET (vec, i, el);
+ }
+
+ unstackify_push (vec);
+}
+
+static void
+DEFUN (unstackify_push_empty_record, (N), unsigned long N)
+{
+ SCHEME_OBJECT res;
+
+ res = (ALLOCATE_RECORD (N));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (unstackify_pop_and_record_set, (N), unsigned long N)
+{
+ SCHEME_OBJECT el, rec;
+
+ el = (unstackify_pop ());
+ rec = (unstackify_tos ());
+ RECORD_SET (rec, N, el);
+}
+
+static void
+DEFUN (unstackify_push_record, (N), unsigned long N)
+{
+ unsigned long i;
+ SCHEME_OBJECT el, rec;
+
+ rec = (ALLOCATE_RECORD (N));
+ for (i = 0; (i < N); i++)
+ {
+ el = (unstackify_pop ());
+ RECORD_SET (rec, i, el);
+ }
+
+ unstackify_push (rec);
+}
+
+static inline void
+DEFUN (unstackify_push_lookup, (N), unsigned long N)
+{
+ unstackify_push (regmap[N]);
+}
+
+static inline void
+DEFUN (unstackify_store, (N), unsigned long N)
+{
+ regmap[N] = (unstackify_tos ());
+}
+
+static void
+DEFUN (unstackify_push_primitive, (N), long N)
+{
+ char * prim_name;
+ SCHEME_OBJECT res;
+
+ prim_name = (unstackify_read_C_string ());
+ res = (MAKE_PRIMITIVE_PROCEDURE (prim_name, N));
+ free (prim_name);
+ unstackify_push (res);
+}
+\f
+static inline void
+DEFUN (unstackify_undefined_opcode, (op), stackify_opcode_t op)
+{
+ outf_fatal ("unstackify/undefined_opcode invoked.\n");
+}
+
+static void
+DEFUN (stackify_push_ulong, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push ((SCHEME_OBJECT) N);
+}
+
+static void
+DEFUN (stackify_push_Pfixnum, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+ long val = ((long) (N));
+
+ unstackify_push (LONG_TO_FIXNUM (val));
+}
+
+static void
+DEFUN (stackify_push__fixnum, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+ long val = (0 - ((long) N));
+
+ unstackify_push (LONG_TO_FIXNUM (val));
+}
+
+static void
+DEFUN (stackify_push_Pinteger, (op), stackify_opcode_t op)
+{
+ unsigned long len;
+ SCHEME_OBJECT res;
+ unsigned char * digits;
+
+ digits = (unstackify_read_string (& len));
+ res = (DIGIT_STRING_TO_INTEGER (false, len, digits));
+
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push__integer, (op), stackify_opcode_t op)
+{
+ unsigned long len;
+ SCHEME_OBJECT res;
+ unsigned char * digits;
+
+ digits = (unstackify_read_string (& len));
+ res = (DIGIT_STRING_TO_INTEGER (true, len, digits));
+
+ unstackify_push (res);
+}
+
+static inline void
+DEFUN (stackify_push_false, (op), stackify_opcode_t op)
+{
+ unstackify_push (SHARP_F);
+}
+
+static inline void
+DEFUN (stackify_push_true, (op), stackify_opcode_t op)
+{
+ unstackify_push (SHARP_T);
+}
+
+static inline void
+DEFUN (stackify_push_nil, (op), stackify_opcode_t op)
+{
+ unstackify_push (EMPTY_LIST);
+}
+
+static void
+DEFUN (stackify_push_flonum, (op), stackify_opcode_t op)
+{
+ double val;
+ SCHEME_OBJECT res;
+ char * str = (unstackify_read_C_string ());
+
+ val = (strtod (((CONST char *) str), ((char **) NULL)));
+ res = (DOUBLE_TO_FLONUM (val));
+ free (str);
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_cons_ratnum, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT num, den, res;
+
+ den = (unstackify_pop ());
+ num = (unstackify_pop ());
+ res = (MAKE_RATIO (num, den));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_cons_recnum, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT real, imag, res;
+
+ imag = (unstackify_pop ());
+ real = (unstackify_pop ());
+ res = (MAKE_COMPLEX (real, imag));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_string, (op), stackify_opcode_t op)
+{
+ unsigned long len;
+ SCHEME_OBJECT res;
+ unsigned char * str;
+
+ str = (unstackify_read_string (& len));
+ res = (C_STRING_TO_SCHEME_STRING (len, ((CONST unsigned char *) str)));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_symbol, (op), stackify_opcode_t op)
+{
+ unsigned long len;
+ SCHEME_OBJECT res;
+ unsigned char * str;
+
+ str = (unstackify_read_string (& len));
+ res = (C_SYM_INTERN (len, str));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_uninterned_symbol, (op), stackify_opcode_t op)
+{
+ unsigned long len;
+ SCHEME_OBJECT res;
+ unsigned char * str;
+
+ str = (unstackify_read_string (& len));
+ res = (C_TO_UNINTERNED_SYMBOL (len, str));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_char, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT res;
+ unsigned long bits, code;
+
+ bits = (unstackify_read_ulong ());
+ code = (unstackify_read_ulong ());
+ res = (MAKE_CHAR (bits, code));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_bit_string, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT res;
+ unsigned char * digits;
+ unsigned long n_bits, len;
+
+ n_bits = (unstackify_read_ulong ());
+ digits = (unstackify_read_string (& len));
+ res = (DIGIT_STRING_TO_BIT_STRING (n_bits, len, digits));
+ unstackify_push (res);
+}
+
+static void
+DEFUN (stackify_push_empty_cons, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT res;
+
+ res = (CONS (SHARP_F, SHARP_F));
+ unstackify_push (res);
+}
+
+static inline void
+DEFUN (stackify_pop_and_set_car, (op), stackify_opcode_t op)
+{
+ unstackify_pop_and_set_cXr (CONS_CAR);
+}
+
+static inline void
+DEFUN (stackify_pop_and_set_cdr, (op), stackify_opcode_t op)
+{
+ unstackify_pop_and_set_cXr (CONS_CDR);
+}
+
+static void
+DEFUN (stackify_push_consS, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_consS (N);
+}
+
+static void
+DEFUN (stackify_push_empty_vector, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_empty_vector (N);
+}
+
+static void
+DEFUN (stackify_pop_and_vector_set, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_pop_and_vector_set (N);
+}
+
+static void
+DEFUN (stackify_push_vector, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_vector (N);
+}
+
+static void
+DEFUN (stackify_push_empty_record, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_empty_record (N);
+}
+
+static void
+DEFUN (stackify_pop_and_record_set, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_pop_and_record_set (N);
+}
+
+static void
+DEFUN (stackify_push_record, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_record (N);
+}
+
+static void
+DEFUN (stackify_push_lookup, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_lookup (N);
+}
+
+static void
+DEFUN (stackify_store, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_store (N);
+}
+
+static void
+DEFUN (stackify_push_constant, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push (MAKE_OBJECT (TC_CONSTANT, N));
+}
+
+static inline void
+DEFUN (stackify_push_unassigned, (op), stackify_opcode_t op)
+{
+ unstackify_push (UNASSIGNED_OBJECT);
+}
+
+static void
+DEFUN (stackify_push_primitive, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push_primitive ((long) N);
+}
+
+static inline void
+DEFUN (stackify_push_primitive_lexpr, (op), stackify_opcode_t op)
+{
+ unstackify_push_primitive (-1);
+}
+
+static void
+DEFUN (stackify_push_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_push_0);
+
+ unstackify_push (LONG_TO_FIXNUM (N));
+}
+
+static void
+DEFUN (stackify_push__1, (op), stackify_opcode_t op)
+{
+ unstackify_push (LONG_TO_FIXNUM (-1));
+}
+
+static inline void
+DEFUN (stackify_push_consS_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_push_consS_0);
+
+ unstackify_push_consS (N);
+}
+
+static inline void
+DEFUN (stackify_pop_and_vector_set_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_pop_and_vector_set_0);
+
+ unstackify_pop_and_vector_set (N);
+}
+
+static inline void
+DEFUN (stackify_push_vector_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (1 + (op - stackify_opcode_push_vector_1));
+
+ unstackify_push_vector (N);
+}
+
+static inline void
+DEFUN (stackify_pop_and_record_set_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_pop_and_record_set_0);
+
+ unstackify_pop_and_record_set (N);
+}
+
+static inline void
+DEFUN (stackify_push_record_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (1 + (op - stackify_opcode_push_record_1));
+
+ unstackify_push_record (N);
+}
+
+static inline void
+DEFUN (stackify_push_lookup_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_push_lookup_0);
+
+ unstackify_push_lookup (N);
+}
+
+static inline void
+DEFUN (stackify_store_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_store_0);
+
+ unstackify_store (N);
+}
+
+static inline void
+DEFUN (stackify_push_primitive_N, (op), stackify_opcode_t op)
+{
+ unsigned long N = (op - stackify_opcode_push_primitive_0);
+
+ unstackify_push_primitive (N);
+}
+\f
+static void
+DEFUN (stackify_push_nm_header, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, N));
+}
+
+static void
+DEFUN (stackify_push_label_entry, (op), stackify_opcode_t op)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push ((SCHEME_OBJECT)
+ (((unsigned long) dispatch_base) + N));
+}
+
+union kludge_u
+{
+ SCHEME_OBJECT obj;
+ format_word arr[sizeof (SCHEME_OBJECT)/sizeof(format_word)];
+};
+
+static void
+DEFUN (stackify_push_label_descriptor, (op), stackify_opcode_t op)
+{
+ unsigned long offset = (unstackify_read_ulong ());
+ unsigned long code_word = (unstackify_read_ulong ());
+ union kludge_u temp[2], * ptr;
+
+ temp[0].obj = ((SCHEME_OBJECT) 0);
+ temp[1].obj = ((SCHEME_OBJECT) 0);
+ ptr = (& temp[1]);
+ WRITE_LABEL_DESCRIPTOR (ptr, code_word, offset);
+ unstackify_push (temp[0].obj);
+}
+
+static void
+DEFUN (stackify_retag_cc_block, (op), stackify_opcode_t op)
+{
+ SCHEME_OBJECT vec = (unstackify_pop ());
+
+ unstackify_push (OBJECT_NEW_TYPE (TC_COMPILED_CODE_BLOCK, vec));
+}
+
+static void
+DEFUN (stackify_cc_block_to_entry, (op), stackify_opcode_t op)
+{
+ unsigned long offset = (unstackify_read_ulong ());
+ SCHEME_OBJECT block = (unstackify_pop ());
+
+ unstackify_push (CC_BLOCK_TO_ENTRY (block, offset));
+}
+
+static void
+DEFUN (stackify_push_return_code, (op), stackify_opcode_t op)
+{
+ unsigned long datum = (unstackify_read_ulong ());
+
+ unstackify_push (MAKE_OBJECT (TC_RETURN_CODE, datum));
+}
+\f
+static void
+DEFUN (unstackify_push_linkage_header, (kind), unsigned long kind)
+{
+ unsigned long N = (unstackify_read_ulong ());
+
+ unstackify_push (MAKE_LINKER_HEADER (kind, N));
+}
+
+static void
+DEFUN (stackify_push_linkage_header_operator, (op), stackify_opcode_t op)
+{
+ unstackify_push_linkage_header (OPERATOR_LINKAGE_KIND);
+}
+
+static void
+DEFUN (stackify_push_linkage_header_reference, (op), stackify_opcode_t op)
+{
+ unstackify_push_linkage_header (REFERENCE_LINKAGE_KIND);
+}
+
+static void
+DEFUN (stackify_push_linkage_header_assignment, (op), stackify_opcode_t op)
+{
+ unstackify_push_linkage_header (ASSIGNMENT_LINKAGE_KIND);
+}
+
+static void
+DEFUN (stackify_push_linkage_header_global, (op), stackify_opcode_t op)
+{
+ unstackify_push_linkage_header (GLOBAL_OPERATOR_LINKAGE_KIND);
+}
+
+static void
+DEFUN (stackify_push_linkage_header_closure, (op), stackify_opcode_t op)
+{
+ outf_fatal ("stackify_push_linkage_header_closure.\n");
+}
+\f
+static void
+DEFUN (unstackify_save_context, (context), stackify_context_t context)
+{
+ context->strptr = strptr;
+ context->dispatch_base = dispatch_base;
+ context->sp = sp;
+ context->regmap = regmap;
+ return;
+}
+
+static void
+DEFUN (unstackify_restore_context, (context), stackify_context_t context)
+{
+ strptr = (context->strptr);
+ dispatch_base = (context->dispatch_base);
+ sp = (context->sp);
+ regmap = (context->regmap);
+ return;
+}
+
+SCHEME_OBJECT
+DEFUN (unstackify, (bytes, db),
+ unsigned char * bytes AND entry_count_t db)
+{
+ unsigned char op;
+ SCHEME_OBJECT result;
+ SCHEME_OBJECT * scratch;
+ unsigned char * pc, * progstart, * progend;
+ unsigned long stack_depth, regmap_size, proglen;
+ stackify_context_s context;
+
+ unstackify_save_context (& context);
+
+ /* Read the header */
+
+ strptr = bytes;
+ DEBUG (strptr_end = (bytes + 4357));
+
+ stack_depth = (unstackify_read_ulong ());
+ regmap_size = (unstackify_read_ulong ());
+ proglen = (unstackify_read_ulong ());
+
+ /* Set up for execution */
+
+ scratch = ((SCHEME_OBJECT *) (malloc ((stack_depth + regmap_size)
+ * (sizeof (SCHEME_OBJECT)))));
+
+ if (scratch == ((SCHEME_OBJECT *) NULL))
+ return (SHARP_F);
+
+ regmap = (scratch + stack_depth);
+ sp = regmap;
+ DEBUG (stack_bot = scratch);
+
+ progstart = strptr;
+ progend = (progstart + proglen);
+ strptr = progend;
+ dispatch_base = db;
+
+ DEBUG (pc_start = progstart);
+ DEBUG (strptr_start = progend);
+ DEBUG (print_everything_count = 0);
+\f
+ /* Now, execute the program */
+
+ for (pc = progstart; (pc < progend); pc++)
+ {
+ op = ((stackify_opcode_t) (* pc));
+ DEBUG (print_everything (op, pc));
+ switch (op)
+ {
+ default:
+ case stackify_opcode_illegal:
+ case stackify_opcode_escape:
+ unstackify_undefined_opcode (op);
+ break;
+
+ case stackify_opcode_push_Pfixnum:
+ stackify_push_Pfixnum (op);
+ break;
+
+ case stackify_opcode_push__fixnum:
+ stackify_push__fixnum (op);
+ break;
+
+ case stackify_opcode_push_Pinteger:
+ stackify_push_Pinteger (op);
+ break;
+
+ case stackify_opcode_push__integer:
+ stackify_push__integer (op);
+ break;
+
+ case stackify_opcode_push_false:
+ stackify_push_false (op);
+ break;
+
+ case stackify_opcode_push_true:
+ stackify_push_true (op);
+ break;
+
+ case stackify_opcode_push_nil:
+ stackify_push_nil (op);
+ break;
+
+ case stackify_opcode_push_flonum:
+ stackify_push_flonum (op);
+ break;
+
+ case stackify_opcode_push_cons_ratnum:
+ stackify_push_cons_ratnum (op);
+ break;
+
+ case stackify_opcode_push_cons_recnum:
+ stackify_push_cons_recnum (op);
+ break;
+
+ case stackify_opcode_push_string:
+ stackify_push_string (op);
+ break;
+
+ case stackify_opcode_push_symbol:
+ stackify_push_symbol (op);
+ break;
+
+ case stackify_opcode_push_uninterned_symbol:
+ stackify_push_uninterned_symbol (op);
+ break;
+\f
+ case stackify_opcode_push_char:
+ stackify_push_char (op);
+ break;
+
+ case stackify_opcode_push_bit_string:
+ stackify_push_bit_string (op);
+ break;
+
+ case stackify_opcode_push_empty_cons:
+ stackify_push_empty_cons (op);
+ break;
+
+ case stackify_opcode_pop_and_set_car:
+ stackify_pop_and_set_car (op);
+ break;
+
+ case stackify_opcode_pop_and_set_cdr:
+ stackify_pop_and_set_cdr (op);
+ break;
+
+ case stackify_opcode_push_consS:
+ stackify_push_consS (op);
+ break;
+
+ case stackify_opcode_push_empty_vector:
+ stackify_push_empty_vector (op);
+ break;
+
+ case stackify_opcode_pop_and_vector_set:
+ stackify_pop_and_vector_set (op);
+ break;
+
+ case stackify_opcode_push_vector:
+ stackify_push_vector (op);
+ break;
+
+ case stackify_opcode_push_empty_record:
+ stackify_push_empty_record (op);
+ break;
+
+ case stackify_opcode_pop_and_record_set:
+ stackify_pop_and_record_set (op);
+ break;
+
+ case stackify_opcode_push_record:
+ stackify_push_record (op);
+ break;
+
+ case stackify_opcode_push_lookup:
+ stackify_push_lookup (op);
+ break;
+
+ case stackify_opcode_store:
+ stackify_store (op);
+ break;
+
+ case stackify_opcode_push_constant:
+ stackify_push_constant (op);
+ break;
+
+ case stackify_opcode_push_unassigned:
+ stackify_push_unassigned (op);
+ break;
+\f
+ case stackify_opcode_push_primitive:
+ stackify_push_primitive (op);
+ break;
+
+ case stackify_opcode_push_primitive_lexpr:
+ stackify_push_primitive_lexpr (op);
+ break;
+
+ case stackify_opcode_push_0:
+ case stackify_opcode_push_1:
+ case stackify_opcode_push_2:
+ case stackify_opcode_push_3:
+ case stackify_opcode_push_4:
+ case stackify_opcode_push_5:
+ case stackify_opcode_push_6:
+ stackify_push_N (op);
+ break;
+
+ case stackify_opcode_push__1:
+ stackify_push__1 (op);
+ break;
+
+ case stackify_opcode_push_consS_0:
+ case stackify_opcode_push_consS_1:
+ case stackify_opcode_push_consS_2:
+ case stackify_opcode_push_consS_3:
+ case stackify_opcode_push_consS_4:
+ case stackify_opcode_push_consS_5:
+ case stackify_opcode_push_consS_6:
+ case stackify_opcode_push_consS_7:
+ stackify_push_consS_N (op);
+ break;
+
+ case stackify_opcode_pop_and_vector_set_0:
+ case stackify_opcode_pop_and_vector_set_1:
+ case stackify_opcode_pop_and_vector_set_2:
+ case stackify_opcode_pop_and_vector_set_3:
+ case stackify_opcode_pop_and_vector_set_4:
+ case stackify_opcode_pop_and_vector_set_5:
+ case stackify_opcode_pop_and_vector_set_6:
+ case stackify_opcode_pop_and_vector_set_7:
+ stackify_pop_and_vector_set_N (op);
+ break;
+
+ case stackify_opcode_push_vector_1:
+ case stackify_opcode_push_vector_2:
+ case stackify_opcode_push_vector_3:
+ case stackify_opcode_push_vector_4:
+ case stackify_opcode_push_vector_5:
+ case stackify_opcode_push_vector_6:
+ case stackify_opcode_push_vector_7:
+ case stackify_opcode_push_vector_8:
+ stackify_push_vector_N (op);
+ break;
+\f
+ case stackify_opcode_pop_and_record_set_0:
+ case stackify_opcode_pop_and_record_set_1:
+ case stackify_opcode_pop_and_record_set_2:
+ case stackify_opcode_pop_and_record_set_3:
+ case stackify_opcode_pop_and_record_set_4:
+ case stackify_opcode_pop_and_record_set_5:
+ case stackify_opcode_pop_and_record_set_6:
+ case stackify_opcode_pop_and_record_set_7:
+ stackify_pop_and_record_set_N (op);
+ break;
+
+ case stackify_opcode_push_record_1:
+ case stackify_opcode_push_record_2:
+ case stackify_opcode_push_record_3:
+ case stackify_opcode_push_record_4:
+ case stackify_opcode_push_record_5:
+ case stackify_opcode_push_record_6:
+ case stackify_opcode_push_record_7:
+ case stackify_opcode_push_record_8:
+ stackify_push_record_N (op);
+ break;
+
+ case stackify_opcode_push_lookup_0:
+ case stackify_opcode_push_lookup_1:
+ case stackify_opcode_push_lookup_2:
+ case stackify_opcode_push_lookup_3:
+ case stackify_opcode_push_lookup_4:
+ case stackify_opcode_push_lookup_5:
+ case stackify_opcode_push_lookup_6:
+ case stackify_opcode_push_lookup_7:
+ stackify_push_lookup_N (op);
+ break;
+
+ case stackify_opcode_store_0:
+ case stackify_opcode_store_1:
+ case stackify_opcode_store_2:
+ case stackify_opcode_store_3:
+ case stackify_opcode_store_4:
+ case stackify_opcode_store_5:
+ case stackify_opcode_store_6:
+ case stackify_opcode_store_7:
+ stackify_store_N (op);
+ break;
+
+ case stackify_opcode_push_primitive_0:
+ case stackify_opcode_push_primitive_1:
+ case stackify_opcode_push_primitive_2:
+ case stackify_opcode_push_primitive_3:
+ case stackify_opcode_push_primitive_4:
+ case stackify_opcode_push_primitive_5:
+ case stackify_opcode_push_primitive_6:
+ case stackify_opcode_push_primitive_7:
+ stackify_push_primitive_N (op);
+ break;
+\f
+ /* Compiler support */
+ /* Ordinary objects don't need the following */
+
+ case stackify_opcode_push_nm_header:
+ stackify_push_nm_header (op);
+ break;
+
+ case stackify_opcode_push_linkage_header_operator:
+ stackify_push_linkage_header_operator (op);
+ break;
+
+ case stackify_opcode_push_linkage_header_reference:
+ stackify_push_linkage_header_reference (op);
+ break;
+
+ case stackify_opcode_push_linkage_header_assignment:
+ stackify_push_linkage_header_assignment (op);
+ break;
+
+ case stackify_opcode_push_linkage_header_global:
+ stackify_push_linkage_header_global (op);
+ break;
+
+ case stackify_opcode_push_linkage_header_closure:
+ stackify_push_linkage_header_closure (op);
+ break;
+
+ case stackify_opcode_push_ulong:
+ stackify_push_ulong (op);
+ break;
+
+ case stackify_opcode_push_label_entry:
+ stackify_push_label_entry (op);
+ break;
+
+ case stackify_opcode_push_label_descriptor:
+ stackify_push_label_descriptor (op);
+ break;
+
+ case stackify_opcode_retag_cc_block:
+ stackify_retag_cc_block (op);
+ break;
+
+ case stackify_opcode_cc_block_to_entry:
+ stackify_cc_block_to_entry (op);
+ break;
+
+ case stackify_opcode_push_return_code:
+ stackify_push_return_code (op);
+ break;
+ }
+ }
+
+ /* Grab the result and return it */
+
+ result = (unstackify_pop ());
+
+ free (scratch);
+
+ unstackify_restore_context (& context);
+
+ return (result);
+}
#| -*-Scheme-*-
-$Id: utabmd.scm,v 9.88 2005/04/16 03:12:24 cph Exp $
+$Id: utabmd.scm,v 9.89 2006/09/16 11:19:09 gjr Exp $
Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
-Copyright 1993,1994,2001,2002,2005 Massachusetts Institute of Technology
+Copyright 1993,1994,2001,2002,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
OS-NAME-STRING ;08
OS-VARIANT-STRING ;09
STACK-TYPE-STRING ;0A
+ MACHINE-TYPE-STRING ;0B
))
;;; This identification string is saved by the system.
-"$Id: utabmd.scm,v 9.88 2005/04/16 03:12:24 cph Exp $"
+"$Id: utabmd.scm,v 9.89 2006/09/16 11:19:09 gjr Exp $"
/* -*-C-*-
-$Id: ux.c,v 1.27 2005/08/22 01:15:07 cph Exp $
+$Id: ux.c,v 1.28 2006/09/16 11:19:09 gjr Exp $
Copyright 1991,1992,1993,1996,1997,2000 Massachusetts Institute of Technology
-Copyright 2002,2003,2005 Massachusetts Institute of Technology
+Copyright 2002,2003,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
}
#endif /* EMULATE_FPATHCONF */
\f
+/* This is called during initialization, when the error system is not
+ set up.
+*/
+
+void *
+DEFUN (OS_malloc_init, (size), unsigned int size)
+{
+ void * result = (UX_malloc (size));
+ return (result);
+}
+
void *
DEFUN (OS_malloc, (size), unsigned int size)
{
/* -*-C-*-
-$Id: ux.h,v 1.78 2005/06/27 06:03:10 cph Exp $
+$Id: ux.h,v 1.79 2006/09/16 11:19:09 gjr Exp $
Copyright 1990,1991,1992,1993,1994,1995 Massachusetts Institute of Technology
Copyright 1996,1997,1998,1999,2000,2003 Massachusetts Institute of Technology
-Copyright 2005 Massachusetts Institute of Technology
+Copyright 2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
# define SYSTEM_VARIANT "Domain"
#endif
+#ifdef __APPLE__
+# define SYSTEM_VARIANT "MacOSX"
+#endif
+
#ifdef __bsdi__ /* works on bsdi 3.0 */
# define SYSTEM_VARIANT "BSDI BSD/OS"
#endif
# define SYSTEM_VARIANT "GNU/Linux"
#endif
+#if defined(__netbsd__) || defined(__NetBSD__)
+# define SYSTEM_VARIANT "NETBSD"
+#endif
+
#ifdef _NEXTOS
# define SYSTEM_VARIANT "NeXT"
#endif
# define EMULATE_GETPAGESIZE
#endif
\f
+#ifdef __APPLE__
+/* poll is somewhat busted on Mac OSX 10.4 (Tiger). Force the use of select */
+
+#undef HAVE_POLL
+#endif
+
#ifdef HAVE_POLL
# ifndef INFTIM
# define INFTIM (-1)
/* -*-C-*-
-$Id: uxproc.c,v 1.29 2003/02/14 18:28:24 cph Exp $
+$Id: uxproc.c,v 1.30 2006/09/16 11:19:09 gjr Exp $
-Copyright (c) 1990-2001 Massachusetts Institute of Technology
+Copyright (c) 1990-2001, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
{
/* If the control terminal is not inherited, force the child
into a different session. */
+#ifdef __APPLE__
+ UX_setsid ();
+#else
if ((UX_setsid ()) < 0)
goto kill_child;
+#endif
/* If the control terminal is explicit, open the given device
now so it becomes the control terminal. */
if (ctty_type == process_ctty_type_explicit)
/* -*-C-*-
-$Id: uxsig.c,v 1.45 2006/03/11 04:15:45 cph Exp $
+$Id: uxsig.c,v 1.46 2006/09/16 11:19:09 gjr Exp $
Copyright 1990,1991,1992,1993,1994,1996 Massachusetts Institute of Technology
-Copyright 2000,2001,2005 Massachusetts Institute of Technology
+Copyright 2000,2001,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
return (SIGACT_HANDLER (&act));
}
+/* Work-around for 64-bit environment bug on Mac OSX */
+
+#if defined(__APPLE__) && defined(__LP64__)
+#define SA_SIGINFO_EXTRA SA_64REGSET
+#endif
+
+#ifndef SA_SIGINFO_EXTRA
+#define SA_SIGINFO_EXTRA 0
+#endif
+
void
DEFUN (INSTALL_HANDLER, (signo, handler),
int signo AND
else
{
(SIGACT_HANDLER (&act)) = handler;
- (act . sa_flags) = SA_SIGINFO;
+ (act . sa_flags) = (SA_SIGINFO | SA_SIGINFO_EXTRA);
}
UX_sigemptyset (& (act . sa_mask));
UX_sigaddset ((& (act . sa_mask)), signo);
defsignal (SIGTRAP, "SIGTRAP", dfl_terminate, CORE_DUMP);
defsignal (SIGIOT, "SIGIOT", dfl_terminate, CORE_DUMP);
defsignal (SIGEMT, "SIGEMT", dfl_terminate, CORE_DUMP);
+#ifndef __APPLE__
defsignal (SIGFPE, "SIGFPE", dfl_terminate, CORE_DUMP);
+#endif /* __APPLE__ */
defsignal (SIGKILL, "SIGKILL", dfl_terminate, (NOIGNORE | NOBLOCK | NOCATCH));
defsignal (SIGBUS, "SIGBUS", dfl_terminate, CORE_DUMP);
defsignal (SIGSEGV, "SIGSEGV", dfl_terminate, CORE_DUMP);
initialize_signal_descriptors ();
initialize_signal_debugging ();
bind_handler (SIGINT, sighnd_control_g);
+#ifndef __APPLE__
bind_handler (SIGFPE, sighnd_fpe);
+#endif /* __APPLE__ */
bind_handler (SIGALRM, sighnd_timer);
bind_handler (SIGVTALRM, sighnd_timer);
bind_handler (SIGUSR1, sighnd_save_then_terminate);
/* -*-C-*-
-$Id: uxtrap.c,v 1.41 2005/06/27 06:03:36 cph Exp $
+$Id: uxtrap.c,v 1.42 2006/09/16 11:19:09 gjr Exp $
Copyright 1990,1991,1992,1993,1995,1997 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003,2005 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
# include "gccode.h"
# if defined(HAVE_SIGCONTEXT) && !defined(USE_STACKLETS)
# define ENABLE_TRAP_RECOVERY 1
+# endif
+ /* FIXME: Support ppc, ppc64, x86_64, and ia64 */
+# if defined(__ppc__) || defined(__ppc64__) || defined(__x86_64__) || defined(__ia64__)
+# undef ENABLE_TRAP_RECOVERY
# endif
#endif
}
}
\f
+#define PC_ALIGNED_P(pc) ((((unsigned long) (pc)) & PC_ALIGNMENT_MASK) == 0)
+
#ifdef ENABLE_TRAP_RECOVERY
/* Heuristic recovery from Unix signals (traps).
#define ALIGNED_P(addr) \
((((unsigned long) (addr)) & SCHEME_ALIGNMENT_MASK) == 0)
-#define PC_ALIGNED_P(pc) ((((unsigned long) (pc)) & PC_ALIGNMENT_MASK) == 0)
-
#define SET_RECOVERY_INFO(s, arg1, arg2) do \
{ \
(recovery_info . state) = s; \
/* -*-C-*-
-$Id: wind.c,v 1.8 2003/02/14 18:28:24 cph Exp $
+$Id: wind.c,v 1.9 2006/09/16 11:19:09 gjr Exp $
-Copyright (C) 1990-1999 Massachusetts Institute of Technology
+Copyright (C) 1990-1999, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
static PTR
DEFUN (xmalloc, (length), unsigned int length)
{
+#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__)
+#else
extern PTR EXFUN (malloc, (unsigned int length));
+#endif
+
PTR result = (malloc (length));
if (result == 0)
error ("malloc", "memory allocation failed");
#| -*-Scheme-*-
-$Id: load.scm,v 14.76 2006/07/26 19:10:33 cph Exp $
+$Id: load.scm,v 14.77 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
(set! load/loading? #f)
(set! load/suppress-loading-message? #f)
(set! load/default-types
- `(("com" ,load/internal)
+ `((#f ,wrapper/load/built-in)
+ ("com" ,load/internal)
("so" ,load-object-file)
("sl" ,load-object-file)
+ ("dylib" ,load-object-file)
("bin" ,load/internal)
("scm" ,load/internal)))
(set! fasload/default-types
- `(("com" ,fasload/internal)
+ `((#f ,wrapper/fasload/built-in)
+ ("so" ,fasload-object-file)
+ ("sl" ,fasload-object-file)
+ ("dylib" ,fasload-object-file)
+ ("com" ,fasload/internal)
("bin" ,fasload/internal)))
(set! load/default-find-pathname-with-type search-types-in-order)
(set! *eval-unit* #f)
(fail)
(values pathname loader)))))))
+(define (try-built-in pathname wrapper)
+ (let ((prim (ucode-primitive initialize-c-compiled-block 1))
+ (d (pathname-directory pathname)))
+ (if (or (not (implemented-primitive-procedure? prim))
+ (not (pair? d)))
+ (values #f #f)
+ (let* ((name (string-append (car (last-pair d))
+ "_"
+ (pathname-name pathname)))
+ (value (prim name)))
+ (if (not value)
+ (values #f #f)
+ (values pathname (wrapper value)))))))
+
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
- (if (pair? types)
- (let ((pathname (pathname-new-type pathname (caar types))))
- (if (file-exists? pathname)
- (values pathname (cadar types))
- (loop (cdr types))))
- (values #f #f))))
+ (cond ((not (pair? types))
+ (values #f #f))
+ ((caar types)
+ (let ((pathname (pathname-new-type pathname (caar types))))
+ (if (file-exists? pathname)
+ (values pathname (cadar types))
+ (loop (cdr types)))))
+ (else
+ (call-with-values
+ (lambda ()
+ (try-built-in pathname (cadar types)))
+ (lambda (pathname loader)
+ (if pathname
+ (values pathname loader)
+ (loop (cdr types)))))))))
+
+;; This always considers a built-in to be the newest.
(define (find-latest-file pathname default-types)
(let loop ((types default-types)
(latest-pathname #f)
(latest-loader #f)
(latest-time 0))
- (if (not (pair? types))
- (values latest-pathname latest-loader)
- (let ((pathname (pathname-new-type pathname (caar types)))
- (skip
+ (cond ((not (pair? types))
+ (values latest-pathname latest-loader))
+ ((not (caar types))
+ (call-with-values
(lambda ()
- (loop (cdr types)
- latest-pathname
- latest-loader
- latest-time))))
- (let ((time (file-modification-time-indirect pathname)))
- (if (and time (> time latest-time))
- (loop (cdr types) pathname (cadar types) time)
- (skip)))))))
+ (try-built-in pathname (cadar types)))
+ (lambda (pathname* loader*)
+ (if pathname*
+ (values pathname* loader*)
+ (loop (cdr types)
+ latest-pathname
+ latest-loader
+ latest-time)))))
+ (else
+ (let ((pathname (pathname-new-type pathname (caar types)))
+ (skip
+ (lambda ()
+ (loop (cdr types)
+ latest-pathname
+ latest-loader
+ latest-time))))
+ (let ((time (file-modification-time-indirect pathname)))
+ (if (and time (> time latest-time))
+ (loop (cdr types) pathname (cadar types) time)
+ (skip))))))))
\f
(define (load/internal pathname environment purify? load-noisily?)
(let* ((port (open-input-file pathname))
(fasload/update-debugging-info! value pathname)
value)))
-(define (load-object-file pathname environment purify? load-noisily?)
- load-noisily? ; ignored
+(define (fasload-object-file pathname suppress-loading-message?)
(loading-message
- load/suppress-loading-message? pathname
+ suppress-loading-message? pathname
(lambda ()
- (let* ((handle
- ((ucode-primitive load-object-file 1) (->namestring pathname)))
- (cth
- ((ucode-primitive object-lookup-symbol 3)
- handle "dload_initialize_file" 0)))
+ (let* ((handle ((ucode-primitive load-object-file 1)
+ (->namestring pathname)))
+ (cth ((ucode-primitive object-lookup-symbol 3)
+ handle "dload_initialize_file" 0)))
(if (not cth)
(error "load-object-file: Cannot find init procedure" pathname))
(let ((scode ((ucode-primitive initialize-c-compiled-block 1)
((ucode-primitive invoke-c-thunk 1)
cth)))))
(fasload/update-debugging-info! scode pathname)
- (load-scode-end scode environment purify?))))))
+ scode)))))
+
+(define (wrapper/fasload/built-in value)
+ (lambda (pathname suppress-loading-message?)
+ (loading-message
+ suppress-loading-message? pathname
+ (lambda ()
+ (fasload/update-debugging-info! value pathname)
+ value))))
+\f
+(define (load-object-file pathname environment purify? load-noisily?)
+ load-noisily? ; ignored
+ (load-scode-end
+ (fasload-object-file pathname load/suppress-loading-message?)
+ environment
+ purify?))
+
+(define (wrapper/load/built-in scode)
+ (lambda (pathname environment purify? load-noisily?)
+ load-noisily? ; ignored
+ (loading-message
+ load/suppress-loading-message? pathname
+ (lambda ()
+ (fasload/update-debugging-info! scode pathname)
+ (load-scode-end scode environment purify?)))))
(define (load-scode-end scode environment purify?)
(if purify? (purify (load/purification-root scode)))
#| -*-Scheme-*-
-$Id: make.scm,v 14.104 2006/09/15 01:23:11 cph Exp $
+$Id: make.scm,v 14.105 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
bin-file)))))
(define (file->object filename purify? optional?)
- (cond ((map-filename filename)
- => (lambda (mapped)
- (fasload mapped purify?)))
- ((not optional?)
- (fatal-error (string-append "Could not find " filename)))
- (else #f)))
+ (let* ((block-name (string-append "runtime_" filename))
+ (value (initialize-c-compiled-block block-name)))
+ (cond (value
+ (tty-write-string newline-string)
+ (tty-write-string block-name)
+ (tty-write-string " initialized")
+ (remember-to-purify purify? filename value))
+ ((map-filename filename)
+ => (lambda (mapped)
+ (fasload mapped purify?)))
+ ((not optional?)
+ (fatal-error (string-append "Could not find " filename)))
+ (else
+ #f))))
(define (eval object environment)
(let ((value (scode-eval object environment)))
(define fasload-purification-queue
'())
+(define (implemented-primitive-procedure? primitive)
+ ((ucode-primitive get-primitive-address)
+ (intern ((ucode-primitive get-primitive-name) (object-datum primitive)))
+ #f))
+
+(define initialize-c-compiled-block
+ (let ((prim (ucode-primitive initialize-c-compiled-block 1)))
+ (if (implemented-primitive-procedure? prim)
+ prim
+ (lambda (name)
+ name ; ignored
+ #f))))
+
(define os-name
(intern os-name-string))
(package/add-child! system-global-package 'PACKAGE environment-for-package)
(define packages-file
- (fasload (cond ((eq? os-name 'NT) "runtime-w32.pkd")
- ((eq? os-name 'OS/2) "runtime-os2.pkd")
- ((eq? os-name 'UNIX) "runtime-unx.pkd")
- (else "runtime-unk.pkd"))
- #f))
+ (let ((name (cond ((eq? os-name 'NT) "runtime-w32")
+ ((eq? os-name 'OS/2) "runtime-os2")
+ ((eq? os-name 'UNIX) "runtime-unx")
+ (else "runtime-unk"))))
+ (or (initialize-c-compiled-block (string-append "runtime_" name))
+ (fasload (string-append name ".pkd") #f))))
+
((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE)
packages-file)
\f
#| -*-Scheme-*-
-$Id: option.scm,v 14.48 2005/08/05 20:03:01 cph Exp $
+$Id: option.scm,v 14.49 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1997,1998,2001,2002 Massachusetts Institute of Technology
-Copyright 2005 Massachusetts Institute of Technology
+Copyright 2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define (standard-load-options)
(or (library-file? "options/optiondb")
+ (library-file? "runtime/optiondb") ; for C back end
(error "Cannot locate a load-option database")
"optiondb"))
(let loop ((file-types load/default-types))
(and (pair? file-types)
(let ((full-pathname (pathname-new-type pathname (caar file-types))))
- (if (file-exists? full-pathname)
- pathname ; not FULL-PATHNAME
- (loop (cdr file-types)))))))
+ (cond ((file-exists? full-pathname)
+ ; not FULL-PATHNAME
+ pathname)
+ ((not (caar file-types))
+ (let ((prim
+ (ucode-primitive initialize-c-compiled-block 1))
+ (d (pathname-directory pathname)))
+ (if (and (implemented-primitive-procedure? prim)
+ (pair? d)
+ (prim (string-append
+ (car (last-pair d))
+ "_"
+ (pathname-name pathname))))
+ pathname
+ (loop (cdr file-types)))))
+ (else
+ (loop (cdr file-types))))))))
(define loaded-options '())
(define *options* '()) ; Current options.
(runtime (pathname-as-directory "runtime")))
(for-each (lambda (file)
(let ((file (force* file)))
- (let* ((options (library-directory-pathname "options"))
- (pathname (merge-pathnames file options)))
- (with-directory-rewriting-rule options runtime
- (lambda ()
- (with-working-directory-pathname
- (directory-pathname pathname)
- (lambda ()
- (load pathname
- environment
- 'DEFAULT
- #t))))))))
+ (cond
+ (((ucode-primitive initialize-c-compiled-block 1)
+ (string-append "runtime_" file))
+ => (lambda (obj)
+ (purify obj)
+ (scode-eval obj environment)))
+ (else
+ (let* ((options (library-directory-pathname "options"))
+ (pathname (merge-pathnames file options)))
+ (with-directory-rewriting-rule options runtime
+ (lambda ()
+ (with-working-directory-pathname
+ (directory-pathname pathname)
+ (lambda ()
+ (load pathname
+ environment
+ 'DEFAULT
+ #t))))))))))
files)
(flush-purification-queue!)
(eval init-expression environment))))
#| -*-Scheme-*-
-$Id: packag.scm,v 14.47 2005/08/05 20:03:05 cph Exp $
+$Id: packag.scm,v 14.48 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,1998,2001,2002,2003 Massachusetts Institute of Technology
-Copyright 2004,2005 Massachusetts Institute of Technology
+Copyright 2004,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
(define system-loader/enable-query? #f)
+(define (quasi-fasload pathname)
+ (let ((prim (ucode-primitive initialize-c-compiled-block 1))
+ (path (merge-pathnames pathname)))
+ (or (and (implemented-primitive-procedure? prim)
+ (prim (string-append (car (last-pair (pathname-directory path)))
+ "_"
+ (pathname-name path))))
+ (fasload pathname))))
+
(define (load-package-set filename #!optional options)
(let ((os-type microcode-id/operating-system))
(let ((pathname (package-set-pathname filename os-type))
(if (default-object? options) '() options))))
(with-working-directory-pathname (directory-pathname pathname)
(lambda ()
- (let ((file (fasload pathname)))
+ (let ((file (quasi-fasload pathname)))
(if (not (package-file? file))
(error "Malformed package-description file:" pathname))
(construct-packages-from-file file)
(lookup-option 'ALTERNATE-PACKAGE-LOADER options))
(load-component
(lambda (component environment)
- (load component environment 'DEFAULT #t))))
+ (let ((value
+ (filename->compiled-object filename component)))
+ (if value
+ (begin
+ (purify (load/purification-root value))
+ (scode-eval value environment))
+ (load component environment 'DEFAULT #t))))))
(if alternate-loader
(alternate-loader load-component options)
(begin
(else "-unk")))
"pkd"
(pathname-version pathname)))
+
+(define (filename->compiled-object system component)
+ (let ((prim (ucode-primitive initialize-c-compiled-block 1)))
+ (and (implemented-primitive-procedure? prim)
+ (let* ((name
+ (let* ((p (->pathname component))
+ (d (pathname-directory p)))
+ (string-append
+ (if (pair? d) (car (last-pair d)) system)
+ "_"
+ (pathname-name p))))
+ (value (prim name)))
+ (if (or (not value) load/suppress-loading-message?)
+ value
+ (let ((port (notification-output-port)))
+ (fresh-line port)
+ (write-string ";Initialized " port)
+ (write name port)
+ value))))))
\f
(define-integrable (make-package-file tag version descriptions loads)
(vector tag version descriptions loads))
#| -*-Scheme-*-
-$Id: random.scm,v 14.37 2005/08/10 18:16:59 cph Exp $
+$Id: random.scm,v 14.38 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1993,1994,1995,1996 Massachusetts Institute of Technology
Copyright 1998,1999,2000,2001,2003,2004 Massachusetts Institute of Technology
-Copyright 2005 Massachusetts Institute of Technology
+Copyright 2005, 2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
unspecific)
(define (finalize-random-state-type!)
- (add-event-receiver! event:after-restore
+ (add-event-receiver! event:after-restart
(lambda ()
(random-source-randomize! *random-state*)
(if (not (eq? default-random-source *random-state*))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.594 2006/09/15 01:23:19 cph Exp $
+$Id: runtime.pkg,v 14.595 2006/09/16 11:19:09 gjr Exp $
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
microcode-error/name->code
microcode-id/floating-epsilon
microcode-id/floating-mantissa-bits
+ microcode-id/machine-type
microcode-id/operating-system
microcode-id/operating-system-name
microcode-id/operating-system-variant
#| -*-Scheme-*-
-$Id: utabs.scm,v 14.19 2005/04/14 04:42:53 cph Exp $
+$Id: utabs.scm,v 14.20 2006/09/16 11:19:09 gjr Exp $
Copyright 1986,1987,1988,1991,1992,1994 Massachusetts Institute of Technology
-Copyright 2001,2003,2005 Massachusetts Institute of Technology
+Copyright 2001,2003,2005,2006 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
(define (read-microcode-tables! #!optional filename)
(set! microcode-tables-identification
- (scode-eval ((ucode-primitive binary-fasload)
- (if (default-object? filename)
- ((ucode-primitive microcode-tables-filename))
- filename))
- system-global-environment))
+ (scode-eval
+ (or (let ((prim ((ucode-primitive get-primitive-address)
+ 'initialize-c-compiled-block
+ #f)))
+ (and prim
+ (prim "microcode_utabmd")))
+ ((ucode-primitive binary-fasload)
+ (if (default-object? filename)
+ ((ucode-primitive microcode-tables-filename))
+ filename)))
+ system-global-environment))
(set! identification-vector ((ucode-primitive microcode-identify)))
(set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR))
(set! identifications-slot
(cond ((string? string) (intern string))
((not string) 'STANDARD)
(else (error "Illegal stack type:" string)))))
+ (set! microcode-id/machine-type
+ (if (microcode-table-search identifications-slot 'MACHINE-TYPE-STRING)
+ (microcode-identification-item 'MACHINE-TYPE-STRING)
+ "unknown-machine"))
(set! microcode-id/tty-x-size
(microcode-identification-item 'CONSOLE-WIDTH))
(set! microcode-id/tty-y-size
(define microcode-id/operating-system-name)
(define microcode-id/operating-system-variant)
(define microcode-id/stack-type)
+(define microcode-id/machine-type)
\f
(define-integrable fixed-objects-slot 15)
(define non-object-slot)
projects / mit-scheme.git / commitdiff