From: Guillermo J. Rozas Date: Sat, 16 Sep 2006 11:19:09 +0000 (+0000) Subject: Changes to resurrect the C back end. X-Git-Tag: 20090517-FFI~936 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e8ff6cb7ee197cd3e0ee56d00575e1674406956d;p=mit-scheme.git Changes to resurrect the C back end. 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). --- diff --git a/v7/src/Setup.sh b/v7/src/Setup.sh index e3c458441..98dd091e7 100755 --- a/v7/src/Setup.sh +++ b/v7/src/Setup.sh @@ -1,8 +1,8 @@ #!/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. # @@ -34,6 +34,7 @@ fi # 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 @@ -45,8 +46,8 @@ maybe_link lib/edwin/etc/TUTORIAL ../../../etc/TUTORIAL 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 diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 06f736857..d78f959f1 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -33,11 +33,13 @@ USA. (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)))) @@ -136,20 +138,25 @@ USA. (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*) @@ -180,7 +187,7 @@ USA. (newline))) (compiler-file-output (transform input-pathname output-pathname) - output-pathname))))) + output-pathname))))) (kernel (if compiler:batch-mode? (batch-kernel core) @@ -195,17 +202,22 @@ USA. (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))))) ;;;; Alternate Entry Points diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index e46fc599b..e2f44dace 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -187,11 +187,14 @@ USA. '|#[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) diff --git a/v7/src/compiler/configure b/v7/src/compiler/configure index b2b124d8a..66bd6f23b 100755 --- a/v7/src/compiler/configure +++ b/v7/src/compiler/configure @@ -1,8 +1,8 @@ #!/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. # @@ -45,8 +45,7 @@ if test ! -e machine; then MACHINE=vax ;; * ) - echo "Unable to determine machine type." - exit 1 + MACHINE=C ;; esac ln -s machines/${MACHINE} machine diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index c27f010eb..5d7b49602 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -28,6 +28,15 @@ USA. (declare (usual-integrations)) +;; 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) @@ -847,8 +856,10 @@ USA. 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) diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg index 61cab8b13..9ca2ea416 100644 --- a/v7/src/compiler/machines/C/compiler.pkg +++ b/v7/src/compiler/machines/C/compiler.pkg @@ -1,8 +1,8 @@ #| -*-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. @@ -34,7 +34,6 @@ USA. "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 @@ -62,6 +61,7 @@ USA. "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 ) @@ -83,6 +83,7 @@ USA. 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? @@ -186,10 +187,34 @@ USA. (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") @@ -211,6 +236,10 @@ USA. 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 @@ -222,6 +251,7 @@ USA. compiler:reset! ;; cross-compile-bin-file ;; cross-compile-bin-file-end + ;; lap->code ) (export (compiler) canonicalize-label-name) @@ -237,6 +267,7 @@ USA. *block-label* *disambiguator* *external-labels* + *shared-namestring* *special-labels* label->object *invoke-interface* @@ -280,6 +311,7 @@ USA. (export (compiler) make-pattern-variable pattern-lookup + pattern-lookup-1 pattern-variable-name pattern-variable? pattern-variables)) @@ -288,10 +320,14 @@ USA. (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) @@ -621,7 +657,9 @@ USA. (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") @@ -643,7 +681,8 @@ USA. (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" ; " " " @@ -652,20 +691,19 @@ USA. "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 @@ -683,7 +721,10 @@ USA. make-table objects permanent-register-list - stringify) + stringify + stringify-data) + (import (runtime string) + %string-append) (import (scode-optimizer expansion) scode->scode-expander)) diff --git a/v7/src/compiler/machines/C/compiler.sf b/v7/src/compiler/machines/C/compiler.sf index ecfa079f8..767fbc2b3 100644 --- a/v7/src/compiler/machines/C/compiler.sf +++ b/v7/src/compiler/machines/C/compiler.sf @@ -1,8 +1,8 @@ #| -*-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. @@ -39,7 +39,8 @@ USA. (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)))) @@ -50,20 +51,17 @@ USA. (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)))) diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm index 01a518695..b2b742d7a 100644 --- a/v7/src/compiler/machines/C/cout.scm +++ b/v7/src/compiler/machines/C/cout.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -28,44 +28,101 @@ USA. (declare (usual-integrations)) -(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)))))))))))) + +(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"))))) + (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 + (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) @@ -82,31 +139,45 @@ USA. (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))))) + (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" @@ -117,19 +188,17 @@ USA. (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" @@ -142,7 +211,7 @@ USA. (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)))) @@ -151,172 +220,272 @@ USA. (define-object (special-label/environment) unspecific) - (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))) + +(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 + (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) + "]);"))))))) +(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")) @@ -330,412 +499,224 @@ USA. (number->string val) val) "\n")) - -;;;; 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))))))))) - -;; 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)))))) - -(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 - '(""))))) - -(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"))) -(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"))) -(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"))) -(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 "\\" @@ -744,48 +725,137 @@ USA. (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'") + +;; 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) '()))) + +(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 + (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 + )) -(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 (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*) @@ -794,26 +864,53 @@ USA. 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))))) +(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 (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))) @@ -825,179 +922,230 @@ USA. (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))))))))))) (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))))) -(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 + (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 + ))) +(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") @@ -1006,18 +1154,47 @@ USA. "_" (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")) + +;; 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))) diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm index a855eb462..080bab934 100644 --- a/v7/src/compiler/machines/C/ctop.scm +++ b/v7/src/compiler/machines/C/ctop.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -32,11 +32,12 @@ USA. (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))) @@ -45,6 +46,11 @@ USA. (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 @@ -114,59 +120,108 @@ USA. ;; (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))))))) + (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))) -(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) @@ -175,73 +230,100 @@ USA. (->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")))) + +(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)))))) - + (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* @@ -252,6 +334,7 @@ USA. ;; Global variables for assembler and linker (define *recursive-compilation-results*) +(define *shared-namestring*) ;; First set: phase/rtl-generation ;; Last used: phase/link @@ -280,6 +363,7 @@ USA. (define *ntags*) (define *labels*) (define *code*) +(define *proxy*) ;; First set: phase/output-generation (define *result*) @@ -299,7 +383,8 @@ USA. ,@some-lap)) (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) @@ -327,7 +412,8 @@ USA. (*C-data-name*) (*ntags*) (*labels*) - (*code*)) + (*code*) + (*proxy*)) (thunk))) (define (assembler&linker-reset!) @@ -357,6 +443,7 @@ USA. (set! *ntags*) (set! *labels*) (set! *code*) + (set! *proxy*) unspecific) (define (initialize-back-end!) @@ -408,12 +495,13 @@ USA. (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) @@ -434,19 +522,22 @@ USA. (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*))) @@ -458,6 +549,7 @@ USA. (set! *entry-label*) (set! *ic-procedure-headers*) (set! *code*) + (set! *proxy*) unspecific))) (define (phase/info-generation-2 labels pathname) @@ -535,4 +627,4 @@ USA. (case char ((#\?) #\P) ((#\!) #\B) - (else #\_))))))))) \ No newline at end of file + (else #\_))))))))) diff --git a/v7/src/compiler/machines/C/decls.scm b/v7/src/compiler/machines/C/decls.scm index dbf2bb927..9e07cacd5 100644 --- a/v7/src/compiler/machines/C/decls.scm +++ b/v7/src/compiler/machines/C/decls.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -196,8 +196,11 @@ USA. (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 @@ -214,10 +217,12 @@ USA. (> 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) @@ -227,10 +232,12 @@ USA. (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))) @@ -239,7 +246,10 @@ USA. (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))) @@ -249,7 +259,10 @@ USA. (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) @@ -270,15 +283,19 @@ USA. (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) @@ -316,7 +333,7 @@ USA. 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" @@ -325,7 +342,8 @@ USA. (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" @@ -348,13 +366,15 @@ USA. (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))))) ;;;; Integration Dependencies (define (initialize/integration-dependencies!) + #| (define (add-declaration! declaration filenames) (for-each (lambda (filenames) (let ((node (filename->source-node filenames))) @@ -363,6 +383,7 @@ USA. (cons declaration (source-node/declarations node))))) filenames)) + |# (let* ((front-end-base (filename/append "base" @@ -374,8 +395,8 @@ USA. (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")) @@ -393,7 +414,8 @@ USA. (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) @@ -440,7 +462,6 @@ USA. (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") @@ -449,6 +470,8 @@ USA. (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") @@ -510,7 +533,9 @@ USA. 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) @@ -519,7 +544,7 @@ USA. (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") diff --git a/v7/src/compiler/machines/C/lapgen.scm b/v7/src/compiler/machines/C/lapgen.scm index 34b3d2412..f9354e3bc 100644 --- a/v7/src/compiler/machines/C/lapgen.scm +++ b/v7/src/compiler/machines/C/lapgen.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -548,7 +548,7 @@ USA. '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")) diff --git a/v7/src/compiler/machines/C/machin.scm b/v7/src/compiler/machines/C/machin.scm index 999e40625..7ab73fc7c 100644 --- a/v7/src/compiler/machines/C/machin.scm +++ b/v7/src/compiler/machines/C/machin.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -50,9 +50,10 @@ USA. ;; 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))) @@ -64,6 +65,9 @@ USA. (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 @@ -132,19 +136,16 @@ USA. ;;; 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 @@ -153,6 +154,7 @@ USA. ;;;; 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 @@ -264,6 +266,8 @@ USA. (case rtl-register ((MEMORY-TOP) register-block/memtop-offset) + ((INT-MASK) + register-block/int-mask-offset) ((STACK-GUARD) register-block/stack-guard-offset) ((ENVIRONMENT) diff --git a/v7/src/compiler/machines/C/make.scm b/v7/src/compiler/machines/C/make.scm index dbbce3d2f..a8446c8c5 100644 --- a/v7/src/compiler/machines/C/make.scm +++ b/v7/src/compiler/machines/C/make.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -29,7 +29,14 @@ USA. (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 diff --git a/v7/src/compiler/machines/C/recomp.scr b/v7/src/compiler/machines/C/recomp.scr deleted file mode 100755 index e459479db..000000000 --- a/v7/src/compiler/machines/C/recomp.scr +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/csh -f - -cd $jw/microcode -make -k -f xmakefile scheme diff --git a/v7/src/compiler/machines/C/rules2.scm b/v7/src/compiler/machines/C/rules2.scm index 3b593da3c..dc65bb3f9 100644 --- a/v7/src/compiler/machines/C/rules2.scm +++ b/v7/src/compiler/machines/C/rules2.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -90,16 +90,16 @@ USA. (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))) diff --git a/v7/src/compiler/machines/C/rulrew.scm b/v7/src/compiler/machines/C/rulrew.scm index 1bd61ee8d..46f5e4837 100644 --- a/v7/src/compiler/machines/C/rulrew.scm +++ b/v7/src/compiler/machines/C/rulrew.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -137,7 +137,7 @@ USA. (define (rtl:constant-fixnum? expression) (and (rtl:constant? expression) - (fix:fixnum? (rtl:constant-value expression)))) + (signed-fixnum? (rtl:constant-value expression)))) (define-rule rewriting (FLOAT-OFFSET (REGISTER (? base register-known-value)) diff --git a/v7/src/compiler/machines/C/stackify.scm b/v7/src/compiler/machines/C/stackify.scm new file mode 100644 index 000000000..f26c4cceb --- /dev/null +++ b/v7/src/compiler/machines/C/stackify.scm @@ -0,0 +1,968 @@ +#| -*-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)) + +(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)) + +;; 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)))))) + +(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)))))) + +(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 + (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))) + +;; 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)))))))) + +;; 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: + (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)))))) + +;; 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)))) + +(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)))) + +(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)) + +;; 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)))) + +(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)) + +(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 + (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)))) + +(define (build/cyclic obj prog curr-depth max-depth regmap) + ;; Outer reference to cyclic object + ;; Returns + (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)))))) + +(define (build/shared obj prog curr-depth max-depth regmap) + ;; First-reference to shared non-cyclic object + ;; Returns + (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 + (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))))))) + +;;; 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) + +;;; 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)))) diff --git a/v7/src/compiler/machines/C/stackops.scm b/v7/src/compiler/machines/C/stackops.scm new file mode 100644 index 000000000..dcfe47fb7 --- /dev/null +++ b/v7/src/compiler/machines/C/stackops.scm @@ -0,0 +1,419 @@ +#| -*-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)) + +;; 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 +) + +(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)) + +(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"))))) diff --git a/v7/src/compiler/machines/C/swmake b/v7/src/compiler/machines/C/swmake deleted file mode 100755 index fd8fd8e07..000000000 --- a/v7/src/compiler/machines/C/swmake +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/csh -f - -make $* -rm -f *.sync diff --git a/v7/src/compiler/machines/C/traditional.scm b/v7/src/compiler/machines/C/traditional.scm new file mode 100644 index 000000000..08e93db9a --- /dev/null +++ b/v7/src/compiler/machines/C/traditional.scm @@ -0,0 +1,436 @@ +#| -*-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)) + +;;;; 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))))))))) + +;; 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)))))) + +(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 + '(""))))) + +(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)) + "))")) + +(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 (->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") + + ((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)))) + +(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 diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index f25ee6397..e7a126cc2 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -387,6 +387,24 @@ USA. (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. @@ -1427,7 +1445,7 @@ USA. (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 () @@ -1452,7 +1470,7 @@ USA. (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 () @@ -1467,17 +1485,17 @@ USA. '(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))) @@ -1496,7 +1514,7 @@ USA. (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 () @@ -1519,7 +1537,7 @@ USA. (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 () @@ -1530,8 +1548,8 @@ USA. '(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) diff --git a/v7/src/etc/script.scm b/v7/src/etc/script.scm new file mode 100644 index 000000000..c627b570b --- /dev/null +++ b/v7/src/etc/script.scm @@ -0,0 +1,64 @@ +#| -*-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"))) + ) diff --git a/v7/src/microcode/bignum.c b/v7/src/microcode/bignum.c index 9b1cb361a..dba1f6185 100644 --- a/v7/src/microcode/bignum.c +++ b/v7/src/microcode/bignum.c @@ -1,10 +1,10 @@ /* -*-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. @@ -679,7 +679,7 @@ DEFUN (bignum_to_double, (bignum), bignum_type bignum) 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 { diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index 5725710ba..42f8ca880 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -1,6 +1,6 @@ /* -*-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 @@ -546,7 +546,7 @@ DEFUN (print_a_bit_string, (from), SCHEME_OBJECT * from) { 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)); @@ -926,7 +926,7 @@ DEFUN (copy_c_compiled_block, (Fre, Old_Contents, Old_Address), #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 */ diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c index afaa11da7..6d27b9a4b 100644 --- a/v7/src/microcode/bitstr.c +++ b/v7/src/microcode/bitstr.c @@ -1,8 +1,8 @@ /* -*-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. @@ -35,8 +35,9 @@ USA. static void EXFUN (copy_bits, (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long)); +extern SCHEME_OBJECT EXFUN (allocate_bit_string, (long)); -static SCHEME_OBJECT +SCHEME_OBJECT DEFUN (allocate_bit_string, (length), long length) { long total_pointers; diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index c9e521d35..418f2551f 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,10 +1,11 @@ /* -*-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. @@ -36,7 +37,12 @@ USA. #include "ostop.h" #include "ostty.h" +#if defined(__linux__) || defined(__APPLE__) || defined(__netbsd__) +#include +#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)); @@ -583,6 +589,7 @@ DEFUN (stack_death, (name), CONST char * name) #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" @@ -617,6 +624,9 @@ DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0) 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); } diff --git a/v7/src/microcode/cmpauxmd/c.c b/v7/src/microcode/cmpauxmd/c.c index 146ecd156..c412cd910 100644 --- a/v7/src/microcode/cmpauxmd/c.c +++ b/v7/src/microcode/cmpauxmd/c.c @@ -1,8 +1,8 @@ /* -*-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. @@ -23,6 +23,8 @@ USA. */ +#include +#define LIARC_IN_MICROCODE #include "liarc.h" #include "prims.h" #include "bignum.h" @@ -31,17 +33,22 @@ USA. #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), @@ -52,7 +59,8 @@ SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()) = ((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 */ @@ -61,29 +69,41 @@ extern char * interface_to_C_hook; 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; }; int pc_zero_bits; @@ -99,13 +119,13 @@ void 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 * @@ -115,7 +135,7 @@ PSEUDO_STATIC tree_node 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))), @@ -129,21 +149,22 @@ DEFUN_VOID (NO_SUBBLOCKS) } 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); @@ -163,7 +184,7 @@ DEFUN (lrealloc, (ptr, size), PTR ptr AND unsigned long size) } int -DEFUN (declare_trampoline_block, (nentries), unsigned long nentries) +DEFUN (declare_trampoline_block, (nentries), entry_count_t nentries) { int result; @@ -218,7 +239,7 @@ DEFUN_VOID (interface_initialize) return; } -unsigned long +entry_count_t DEFUN (find_compiled_block, (name), char * name) { tree_node node = (tree_lookup (compiled_blocks_tree, name)); @@ -234,18 +255,19 @@ DEFUN (declare_compiled_data, (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) (); } @@ -253,40 +275,52 @@ SCHEME_OBJECT 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); } 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) { @@ -300,7 +334,7 @@ DEFUN (declare_compiled_code, 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); @@ -310,9 +344,9 @@ DEFUN (declare_compiled_code, } 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 */ @@ -321,7 +355,7 @@ DEFUN (declare_compiled_code, 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) @@ -340,7 +374,7 @@ DEFUN (declare_compiled_code, 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)); @@ -368,9 +402,10 @@ DEFUN (declare_compiled_code, 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++) { @@ -380,7 +415,71 @@ DEFUN (declare_compiled_code, } return (* decl_code) (); } + +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); +} + /* For now */ extern SCHEME_OBJECT @@ -526,8 +625,10 @@ Set the C transfer counter to new-value. Return the old value.") 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[]; @@ -535,7 +636,11 @@ SCHEME_OBJECT * 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); } int @@ -559,7 +664,7 @@ DEFUN (multiply_with_overflow, (x, y, res), long x AND long y AND long * res) } 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); @@ -572,12 +677,14 @@ DEFUN (hex_digit_to_int, (h_digit), char 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; @@ -585,7 +692,7 @@ DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits), 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; @@ -600,22 +707,18 @@ DEFUN (digit_string_to_bit_string, (n_bits, n_digits, digits), /* 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)); @@ -623,15 +726,21 @@ DEFUN (digit_string_producer, (digit_ptr), char ** digit_ptr) 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)); } #ifdef USE_STDARG diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index a5f2dec9a..4f658c89f 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-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 @@ -240,7 +240,7 @@ EXTENTRY (interface_to_scheme); #define ENTER_SCHEME(ep) return (C_to_interface ((PTR) (ep))) -#else /* CMPINT_USE_STRUCS */ +#else /* not CMPINT_USE_STRUCS */ typedef instruction * utility_result; @@ -256,14 +256,14 @@ long C_return_value; #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) @@ -839,13 +839,6 @@ DEFINE_SCHEME_UTILITY_1 (comutil_return_to_interpreter, tramp_data_raw) RETURN_TO_C (PRIM_DONE); } -#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)); @@ -855,6 +848,13 @@ static void EXFUN 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))) \ diff --git a/v7/src/microcode/cmpintmd/c.h b/v7/src/microcode/cmpintmd/c.h index b9b4a9a1f..72bbfc87d 100644 --- a/v7/src/microcode/cmpintmd/c.h +++ b/v7/src/microcode/cmpintmd/c.h @@ -1,8 +1,8 @@ /* -*-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. @@ -31,12 +31,16 @@ USA. #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) diff --git a/v7/src/microcode/comlin.c b/v7/src/microcode/comlin.c index 0ecf60807..35d0285a0 100644 --- a/v7/src/microcode/comlin.c +++ b/v7/src/microcode/comlin.c @@ -1,6 +1,6 @@ /* -*-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. @@ -21,7 +21,7 @@ USA. */ -/* $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. * @@ -215,7 +215,7 @@ DEFUN (parse_keywords, case BOOLEAN_KYWRD: { - boolean value; + boolean value = false; if (*argument != '\0') { diff --git a/v7/src/microcode/compinit.c b/v7/src/microcode/compinit.c index 14f8ec6c6..c3457ea38 100644 --- a/v7/src/microcode/compinit.c +++ b/v7/src/microcode/compinit.c @@ -1,8 +1,8 @@ /* -*-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. @@ -23,16 +23,18 @@ USA. */ +#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) \ @@ -42,12 +44,21 @@ USA. #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) { diff --git a/v7/src/microcode/comutl.c b/v7/src/microcode/comutl.c index 3a575946c..a700da407 100644 --- a/v7/src/microcode/comutl.c +++ b/v7/src/microcode/comutl.c @@ -1,8 +1,8 @@ /* -*-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. @@ -167,13 +167,10 @@ DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK", "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); diff --git a/v7/src/microcode/configure.ac b/v7/src/microcode/configure.ac index 35bebb04f..14e0b83a0 100644 --- a/v7/src/microcode/configure.ac +++ b/v7/src/microcode/configure.ac @@ -1,7 +1,7 @@ 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 @@ -148,6 +148,10 @@ DLD_LDFLAGS= 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 @@ -828,6 +832,11 @@ hppa*) i?86) scheme_arch=i386 ;; +# x86_64) +# scheme_arch=i386 +# CFLAGS="${CFLAGS} -m32" +# LDFLAGS="${LDFLAGS} -m32" +# ;; m68k|m680?0) scheme_arch=mc68k ;; @@ -846,6 +855,21 @@ if test "${scheme_arch}" != ""; then 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 @@ -884,6 +908,10 @@ AC_SUBST([MODULE_TARGETS]) 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 diff --git a/v7/src/microcode/confshared.h b/v7/src/microcode/confshared.h index 4593cbbbf..556d897d3 100644 --- a/v7/src/microcode/confshared.h +++ b/v7/src/microcode/confshared.h @@ -1,8 +1,8 @@ /* -*-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. @@ -123,6 +123,10 @@ typedef unsigned long SCHEME_OBJECT; #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 #ifdef vax @@ -130,7 +134,6 @@ typedef unsigned long SCHEME_OBJECT; #define MACHINE_TYPE "vax" #define FASL_INTERNAL_FORMAT FASL_VAX -#define TYPE_CODE_LENGTH 6 #define HEAP_IN_LOW_MEMORY /* Not on these, however */ @@ -189,7 +192,6 @@ typedef unsigned long SCHEME_OBJECT; #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. @@ -239,7 +241,6 @@ typedef unsigned long SCHEME_OBJECT; #define FASL_INTERNAL_FORMAT FASL_68020 #endif #define HEAP_IN_LOW_MEMORY -#define TYPE_CODE_LENGTH 6 #endif /* hp9000s300 */ @@ -270,7 +271,6 @@ typedef unsigned long SCHEME_OBJECT; #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 @@ -285,7 +285,6 @@ typedef unsigned long SCHEME_OBJECT; #ifdef NeXT # define MACHINE_TYPE "next" # define FASL_INTERNAL_FORMAT FASL_68020 -# define TYPE_CODE_LENGTH 6 # define HEAP_IN_LOW_MEMORY #endif @@ -297,7 +296,6 @@ typedef unsigned long SCHEME_OBJECT; #define FASL_INTERNAL_FORMAT FASL_IA32 #define HEAP_IN_LOW_MEMORY -#define TYPE_CODE_LENGTH 6 #ifdef sequent # define MACHINE_TYPE "sequent386" @@ -311,13 +309,16 @@ typedef unsigned long SCHEME_OBJECT; # define MACHINE_TYPE "IA-32" #endif +#ifdef NATIVE_CODE_IS_C +#undef HEAP_IN_LOW_MEMORY +#endif + #endif /* __IA32__ */ #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) @@ -482,7 +483,6 @@ extern void EXFUN (win32_stack_reset, (void)); #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 @@ -499,13 +499,31 @@ extern void EXFUN (win32_stack_reset, (void)); #define MAX_FLONUM_EXPONENT 1023 #endif +#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 + #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 @@ -522,7 +540,7 @@ extern void EXFUN (win32_stack_reset, (void)); #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. */ diff --git a/v7/src/microcode/error.c b/v7/src/microcode/error.c index e45f2ee61..0cc6062e7 100644 --- a/v7/src/microcode/error.c +++ b/v7/src/microcode/error.c @@ -1,8 +1,8 @@ /* -*-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. @@ -30,7 +30,11 @@ USA. 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) { diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h index 18e11c9b3..29df072c2 100644 --- a/v7/src/microcode/fasl.h +++ b/v7/src/microcode/fasl.h @@ -1,8 +1,8 @@ /* -*-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. @@ -30,7 +30,11 @@ USA. /* 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: */ diff --git a/v7/src/microcode/history.h b/v7/src/microcode/history.h index 525d06dbb..854f45ed6 100644 --- a/v7/src/microcode/history.h +++ b/v7/src/microcode/history.h @@ -1,8 +1,8 @@ /* -*-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. @@ -40,7 +40,7 @@ USA. #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" diff --git a/v7/src/microcode/liarc.h b/v7/src/microcode/liarc.h index a0887a601..1e7bd0f04 100644 --- a/v7/src/microcode/liarc.h +++ b/v7/src/microcode/liarc.h @@ -1,8 +1,8 @@ /* -*-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. @@ -35,10 +35,6 @@ USA. #ifndef MIT_SCHEME #define MIT_SCHEME #endif - -#ifndef NATIVE_CODE_IS_C -#define NATIVE_CODE_IS_C -#endif #include #include "config.h" @@ -53,6 +49,9 @@ USA. #include "prim.h" #include "cmpgc.h" #include "cmpintmd.h" +#include "trap.h" +#include "outf.h" +#include "extern.h" #ifdef __STDC__ # define USE_STDARG @@ -61,7 +60,19 @@ USA. # include #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; @@ -80,6 +91,8 @@ union machine_word_u }; typedef union machine_word_u machine_word; + +typedef unsigned long entry_count_t; #define ADDRESS_UNITS_PER_OBJECT (sizeof (SCHEME_OBJECT)) #define ADDRESS_UNITS_PER_FLOAT (sizeof (double)) @@ -102,7 +115,7 @@ typedef union machine_word_u machine_word; (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)) @@ -150,7 +163,7 @@ typedef union machine_word_u machine_word; #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) @@ -160,11 +173,35 @@ typedef union machine_word_u machine_word; #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; \ @@ -330,6 +367,19 @@ REGISTER SCHEME_OBJECT * Rsp = sp_register /* 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, \ @@ -347,20 +397,45 @@ REGISTER SCHEME_OBJECT * Rsp = sp_register 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) + #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) \ @@ -368,7 +443,7 @@ REGISTER SCHEME_OBJECT * Rsp = sp_register 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)); \ @@ -379,11 +454,21 @@ REGISTER SCHEME_OBJECT * Rsp = sp_register 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)); \ \ @@ -398,7 +483,20 @@ REGISTER SCHEME_OBJECT * Rsp = sp_register 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 */ @@ -414,18 +512,24 @@ extern int 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)), @@ -465,41 +569,52 @@ extern 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 \ @@ -516,16 +631,20 @@ extern SCHEME_OBJECT EXFUN ((* (constructor_kludge [10])), ()); ((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 */ diff --git a/v7/src/microcode/makegen/Makefile.in.in b/v7/src/microcode/makegen/Makefile.in.in index e1a19a9ed..05754feb3 100644 --- a/v7/src/microcode/makegen/Makefile.in.in +++ b/v7/src/microcode/makegen/Makefile.in.in @@ -1,6 +1,6 @@ # -*- 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 # @@ -60,6 +60,20 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs # **** 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 @@ -71,7 +85,7 @@ TAR = tar 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@ @@ -89,8 +103,8 @@ ASSEMBLE = $(AS) $(AS_FLAGS) # **** 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@ @@ -182,7 +196,7 @@ MOSTLYCLEAN_FILES = *.o cmpauxmd.s usrdef.c bchdef.c 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 @@ -192,7 +206,7 @@ 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 @@ -210,7 +224,7 @@ scheme: $(scheme_OBJECTS) $(scheme_DEPENDENCIES) -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 @@ -218,7 +232,7 @@ bchscheme: $(bchscheme_OBJECTS) $(bchscheme_DEPENDENCIES) -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 @@ -337,6 +351,53 @@ install-auxDATA: $(aux_DATA) @(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: diff --git a/v7/src/microcode/makegen/files-compiled.scm b/v7/src/microcode/makegen/files-compiled.scm new file mode 100644 index 000000000..ad1db18af --- /dev/null +++ b/v7/src/microcode/makegen/files-compiled.scm @@ -0,0 +1,41 @@ +#| -*-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" diff --git a/v7/src/microcode/makegen/makegen.scm b/v7/src/microcode/makegen/makegen.scm index 08d7b5394..81dda54ab 100644 --- a/v7/src/microcode/makegen/makegen.scm +++ b/v7/src/microcode/makegen/makegen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -99,6 +99,18 @@ USA. ((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))))))) @@ -106,8 +118,10 @@ USA. (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> CODE_LENGTH) & CHAR_MASK_BITS) diff --git a/v7/src/microcode/option.c b/v7/src/microcode/option.c index ed51758c8..1fb36412c 100644 --- a/v7/src/microcode/option.c +++ b/v7/src/microcode/option.c @@ -1,10 +1,10 @@ /* -*-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. @@ -1015,6 +1015,8 @@ DEFUN (read_band_header, (filename, header), CONST char * filename AND SCHEME_OBJECT * header) { + int result = 1; + #ifdef __WIN32__ HANDLE handle @@ -1029,14 +1031,12 @@ DEFUN (read_band_header, (filename, header), 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__ */ @@ -1045,14 +1045,24 @@ DEFUN (read_band_header, (filename, header), 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 @@ -1181,6 +1191,7 @@ DEFUN (read_command_line_options, (argc, argv), 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; @@ -1304,6 +1315,9 @@ DEFUN (read_command_line_options, (argc, argv), (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) @@ -1315,15 +1329,22 @@ DEFUN (read_command_line_options, (argc, argv), 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. */ diff --git a/v7/src/microcode/os.h b/v7/src/microcode/os.h index f9212172b..e9b52a2cd 100644 --- a/v7/src/microcode/os.h +++ b/v7/src/microcode/os.h @@ -1,8 +1,8 @@ /* -*-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. @@ -30,6 +30,7 @@ USA. 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)); diff --git a/v7/src/microcode/os2.c b/v7/src/microcode/os2.c index 7033422fa..8d24624c0 100644 --- a/v7/src/microcode/os2.c +++ b/v7/src/microcode/os2.c @@ -1,8 +1,8 @@ /* -*-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. @@ -155,6 +155,17 @@ OS_free (void * ptr) #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) { diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c index 6d973384b..a12f79cf6 100644 --- a/v7/src/microcode/ppband.c +++ b/v7/src/microcode/ppband.c @@ -1,6 +1,6 @@ /* -*-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 @@ -74,8 +74,11 @@ USA. # 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." @@ -310,8 +313,12 @@ DEFUN (scheme_symbol, (From), unsigned long From) # 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." diff --git a/v7/src/microcode/prim.c b/v7/src/microcode/prim.c index 88c1ce4c5..8965c847f 100644 --- a/v7/src/microcode/prim.c +++ b/v7/src/microcode/prim.c @@ -1,9 +1,9 @@ /* -*-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. @@ -98,7 +98,8 @@ Return the object datum corresponding to ADDRESS.") { 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))))); } DEFINE_PRIMITIVE ("MAKE-NON-POINTER-OBJECT", Prim_make_non_ptr_object, 1, 1, diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c index a2f13bc7d..6be88e09f 100644 --- a/v7/src/microcode/primutl.c +++ b/v7/src/microcode/primutl.c @@ -1,8 +1,8 @@ /* -*-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. @@ -345,9 +345,25 @@ DEFUN (install_primitive, (name, code, nargs_lo, nargs_hi, docstr), 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, diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index c47b87f17..279b00e40 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -1,6 +1,6 @@ /* -*-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 @@ -759,7 +759,7 @@ DEFUN (when, (what, message), Boolean what AND char * message) 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*/ @@ -870,7 +870,7 @@ DEFUN (Read_Pointers_and_Relocate, (how_many, to), 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]; @@ -1159,8 +1159,8 @@ DEFUN_VOID (Read_Header_and_Allocate) 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); } @@ -1173,7 +1173,8 @@ DEFUN_VOID (Read_Header_and_Allocate) { 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", @@ -1196,7 +1197,7 @@ DEFUN_VOID (Read_Header_and_Allocate) 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); @@ -1309,7 +1310,7 @@ DEFUN_VOID (do_it) 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; diff --git a/v7/src/microcode/ptrvec.c b/v7/src/microcode/ptrvec.c index a672e2eb2..b956cece0 100644 --- a/v7/src/microcode/ptrvec.c +++ b/v7/src/microcode/ptrvec.c @@ -1,8 +1,8 @@ /* -*-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. @@ -26,10 +26,15 @@ USA. #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) { @@ -43,7 +48,6 @@ DEFUN (xmalloc, (length), unsigned int length) 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) { diff --git a/v7/src/microcode/stackops.h b/v7/src/microcode/stackops.h new file mode 100644 index 000000000..258bc138b --- /dev/null +++ b/v7/src/microcode/stackops.h @@ -0,0 +1,157 @@ +/* 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 */ diff --git a/v7/src/microcode/tterm.c b/v7/src/microcode/tterm.c index d5d7ca50a..fb9866fa9 100644 --- a/v7/src/microcode/tterm.c +++ b/v7/src/microcode/tterm.c @@ -1,8 +1,8 @@ /* -*-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. @@ -112,6 +112,9 @@ DEFINE_PRIMITIVE ("TERMCAP-PARAM-STRING", Prim_termcap_param_string, 5, 5, 0) 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)), @@ -119,6 +122,7 @@ DEFINE_PRIMITIVE ("TERMCAP-PARAM-STRING", Prim_termcap_param_string, 5, 5, 0) (arg_nonnegative_integer (4)), (arg_nonnegative_integer (5))); PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) s)); +#endif } } diff --git a/v7/src/microcode/unstackify.c b/v7/src/microcode/unstackify.c new file mode 100644 index 000000000..a9926aa07 --- /dev/null +++ b/v7/src/microcode/unstackify.c @@ -0,0 +1,1402 @@ +/* -*-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 +#include +#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) + +#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 */ + +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; +} + +/* 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); +} + +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); +} + +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); +} + +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)); +} + +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"); +} + +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); + + /* 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; + + 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; + + 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; + + 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; + + /* 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); +} diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index 5669c6914..f79c5f191 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -607,8 +607,9 @@ USA. 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 $" diff --git a/v7/src/microcode/ux.c b/v7/src/microcode/ux.c index a7691a6a0..512560240 100644 --- a/v7/src/microcode/ux.c +++ b/v7/src/microcode/ux.c @@ -1,9 +1,9 @@ /* -*-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. @@ -616,6 +616,17 @@ DEFUN (fpathconf, (filedes, parameter), int filedes AND int parameter) } #endif /* EMULATE_FPATHCONF */ +/* 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) { diff --git a/v7/src/microcode/ux.h b/v7/src/microcode/ux.h index cc83ff4e0..568b091fa 100644 --- a/v7/src/microcode/ux.h +++ b/v7/src/microcode/ux.h @@ -1,10 +1,10 @@ /* -*-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. @@ -44,6 +44,10 @@ USA. # 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 @@ -64,6 +68,10 @@ USA. # define SYSTEM_VARIANT "GNU/Linux" #endif +#if defined(__netbsd__) || defined(__NetBSD__) +# define SYSTEM_VARIANT "NETBSD" +#endif + #ifdef _NEXTOS # define SYSTEM_VARIANT "NeXT" #endif @@ -581,6 +589,12 @@ typedef RETSIGTYPE Tsignal_handler_result; # define EMULATE_GETPAGESIZE #endif +#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) diff --git a/v7/src/microcode/uxproc.c b/v7/src/microcode/uxproc.c index 95e2ca0a0..a814351c8 100644 --- a/v7/src/microcode/uxproc.c +++ b/v7/src/microcode/uxproc.c @@ -1,8 +1,8 @@ /* -*-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. @@ -335,8 +335,12 @@ DEFUN (OS_make_subprocess, { /* 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) diff --git a/v7/src/microcode/uxsig.c b/v7/src/microcode/uxsig.c index f99f7c6e8..dd9a1d498 100644 --- a/v7/src/microcode/uxsig.c +++ b/v7/src/microcode/uxsig.c @@ -1,9 +1,9 @@ /* -*-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. @@ -63,6 +63,16 @@ DEFUN (current_handler, (signo), int signo) 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 @@ -78,7 +88,7 @@ DEFUN (INSTALL_HANDLER, (signo, handler), 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); @@ -328,7 +338,9 @@ DEFUN_VOID (initialize_signal_descriptors) 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); @@ -676,7 +688,9 @@ DEFUN_VOID (UX_initialize_signals) 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); diff --git a/v7/src/microcode/uxtrap.c b/v7/src/microcode/uxtrap.c index d391399f5..bc584e1ed 100644 --- a/v7/src/microcode/uxtrap.c +++ b/v7/src/microcode/uxtrap.c @@ -1,9 +1,9 @@ /* -*-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. @@ -35,6 +35,10 @@ USA. # 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 @@ -316,6 +320,8 @@ DEFUN (trap_handler, (message, signo, info, scp), } } +#define PC_ALIGNED_P(pc) ((((unsigned long) (pc)) & PC_ALIGNMENT_MASK) == 0) + #ifdef ENABLE_TRAP_RECOVERY /* Heuristic recovery from Unix signals (traps). @@ -335,8 +341,6 @@ DEFUN (trap_handler, (message, signo, info, scp), #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; \ diff --git a/v7/src/microcode/wind.c b/v7/src/microcode/wind.c index db6d8af1b..7beaaf64e 100644 --- a/v7/src/microcode/wind.c +++ b/v7/src/microcode/wind.c @@ -1,8 +1,8 @@ /* -*-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. @@ -47,7 +47,11 @@ DEFUN (error, (procedure_name, message), 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"); diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index ada028759..ae8c300dd 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,13 +36,19 @@ USA. (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) @@ -189,33 +195,70 @@ USA. (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)))))))) (define (load/internal pathname environment purify? load-noisily?) (let* ((port (open-input-file pathname)) @@ -253,16 +296,14 @@ USA. (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) @@ -270,7 +311,31 @@ USA. ((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)))) + +(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))) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index eb0ebfb6f..d226e8224 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -243,12 +243,20 @@ USA. 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))) @@ -280,6 +288,19 @@ USA. (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)) @@ -316,11 +337,13 @@ USA. (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) diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index 8694c9291..b40e1b6f8 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -88,6 +88,7 @@ USA. (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")) @@ -99,9 +100,23 @@ USA. (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. @@ -117,17 +132,24 @@ USA. (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)))) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index a2de009e3..0707f39a1 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -165,6 +165,15 @@ USA. (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)) @@ -173,7 +182,7 @@ USA. (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) @@ -188,7 +197,13 @@ USA. (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 @@ -213,6 +228,25 @@ USA. (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)))))) (define-integrable (make-package-file tag version descriptions loads) (vector tag version descriptions loads)) diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm index 112bc769f..d840184a7 100644 --- a/v7/src/runtime/random.scm +++ b/v7/src/runtime/random.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -402,7 +402,7 @@ USA. 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*)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 06b21bd40..44f585895 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -2440,6 +2440,7 @@ USA. 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 diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm index 236c6b04b..bc8f93795 100644 --- a/v7/src/runtime/utabs.scm +++ b/v7/src/runtime/utabs.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -54,11 +54,17 @@ USA. (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 @@ -94,6 +100,10 @@ USA. (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 @@ -126,6 +136,7 @@ USA. (define microcode-id/operating-system-name) (define microcode-id/operating-system-variant) (define microcode-id/stack-type) +(define microcode-id/machine-type) (define-integrable fixed-objects-slot 15) (define non-object-slot)