From fc2cee105782d4393f6394f70b67628b748e07b0 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 3 Mar 2017 16:08:15 -0700 Subject: [PATCH] Load runtime/host-adapter when building a cross-compiler. Define GUARANTEE which is now used in the new compiler/sf/cref. Collect a couple other existing hacks to the host runtime. Increment the CREF version since it grew deprecated bindings. --- src/Makefile.tools.in | 5 +- src/compiler/base/utils.scm | 7 -- src/compiler/rtlgen/opncod.scm | 11 ++-- src/cref/make.scm | 52 +-------------- src/runtime/bytevector.scm | 5 +- src/runtime/host-adapter.scm | 103 ++++++++++++++++++++++++++++++ src/runtime/predicate-tagging.scm | 7 +- 7 files changed, 115 insertions(+), 75 deletions(-) create mode 100644 src/runtime/host-adapter.scm diff --git a/src/Makefile.tools.in b/src/Makefile.tools.in index 8e4a3a93a..23f09cc83 100644 --- a/src/Makefile.tools.in +++ b/src/Makefile.tools.in @@ -63,11 +63,14 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ HOST_COMPILER = $(HOST_TOOLCHAIN) -HOST_RUNTIME = '$(MIT_SCHEME_EXE)' --batch-mode --band runtime.com +HOST_RUNTIME = '$(MIT_SCHEME_EXE)' --batch-mode --band runtime.com \ + --eval '(load "runtime/host-adapter")' HOST_SYNTAXER = '$(MIT_SCHEME_EXE)' --batch-mode --band runtime.com \ + --eval '(load "runtime/host-adapter")' \ --eval '(load-option (quote CREF))' \ --eval '(load-option (quote SF))' HOST_TOOLCHAIN = '$(MIT_SCHEME_EXE)' --batch-mode \ + --eval '(load "runtime/host-adapter")' \ --eval '(load-option (quote CREF))' SUBDIRS = compiler cref runtime sf star-parser diff --git a/src/compiler/base/utils.scm b/src/compiler/base/utils.scm index 1f0813b61..f5e0a36cd 100644 --- a/src/compiler/base/utils.scm +++ b/src/compiler/base/utils.scm @@ -31,13 +31,6 @@ USA. ;;;; Miscellaneous -;; Temporary definition, for 9.2 hosts. -(define (random-bytevector n #!optional state) - (let ((env (->environment '(runtime random-number)))) - ((if (environment-bound? env 'random-byte-vector) - (access random-byte-vector env) - (access random-bytevector env)) n state))) - (define (three-way-sort = set set* receiver) (let ((member? (member-procedure =))) (define (loop set set* receiver) diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index ce7933d49..842043b5a 100644 --- a/src/compiler/rtlgen/opncod.scm +++ b/src/compiler/rtlgen/opncod.scm @@ -660,9 +660,6 @@ USA. '(0) false)) -;;; TODO(cph): eliminate after 9.3 release: -(define-integrable bytevector-type #x33) - (let ((open-code/type-test (lambda (type) (lambda (combination expressions finish) @@ -683,7 +680,7 @@ USA. (simple-type-test 'FIXNUM? (ucode-type fixnum)) (simple-type-test 'FLONUM? (ucode-type flonum)) (simple-type-test 'BIT-STRING? (ucode-type vector-1b)) - (simple-type-test 'BYTEVECTOR? bytevector-type))) + (simple-type-test 'BYTEVECTOR? (ucode-type bytevector)))) (define-open-coder/predicate 'EQ? (simple-open-coder @@ -1019,7 +1016,7 @@ USA. (user-ref '%RECORD-LENGTH rtl:vector-length-fetch (ucode-type record) 0) (user-ref 'STRING-LENGTH rtl:length-fetch (ucode-type string) 1) (user-ref 'BIT-STRING-LENGTH rtl:length-fetch (ucode-type vector-1b) 1) - (user-ref 'BYTEVECTOR-LENGTH rtl:length-fetch bytevector-type 1) + (user-ref 'BYTEVECTOR-LENGTH rtl:length-fetch (ucode-type bytevector) 1) (user-ref 'FLOATING-VECTOR-LENGTH rtl:floating-vector-length-fetch (ucode-type flonum) @@ -1173,7 +1170,7 @@ USA. (define-open-coder/value 'BYTEVECTOR-U8-REF (simple-open-coder - (string-memory-reference 'BYTEVECTOR-U8-REF bytevector-type #f + (string-memory-reference 'BYTEVECTOR-U8-REF (ucode-type bytevector) #f (lambda (locative expressions finish) expressions (finish (rtl:bytevector-fetch locative)))) @@ -1202,7 +1199,7 @@ USA. (define-open-coder/effect 'BYTEVECTOR-U8-SET! (simple-open-coder (string-memory-reference 'BYTEVECTOR-U8-SET! - bytevector-type + (ucode-type bytevector) (ucode-type fixnum) (lambda (locative expressions finish) (finish-bytevector-assignment locative (caddr expressions) finish))) diff --git a/src/cref/make.scm b/src/cref/make.scm index e4ff75665..40b33c6e3 100644 --- a/src/cref/make.scm +++ b/src/cref/make.scm @@ -32,54 +32,4 @@ USA. (lambda () (load-package-set "cref"))) -;;; Patch the package loader in 9.2 host runtimes. -(if (string-prefix? "9.2" (get-subsystem-version-string "Release")) - (eval - '(begin - (define (link-description? object) - (and (vector? object) - (cond ((fix:= (vector-length object) 2) - (and (symbol? (vector-ref object 0)) - (package-name? (vector-ref object 1)))) - ((fix:= (vector-length object) 3) - (and (symbol? (vector-ref object 0)) - (package-name? (vector-ref object 1)) - (symbol? (vector-ref object 2)))) - ((fix:= (vector-length object) 4) - (and (symbol? (vector-ref object 0)) - (package-name? (vector-ref object 1)) - (symbol? (vector-ref object 2)) - (or (eq? #f (vector-ref object 3)) - (eq? 'deprecated (vector-ref object 3))))) - (else #f)))) - (define (create-links-from-description description) - (let ((environment - (find-package-environment (package-description/name description)))) - (let ((bindings (package-description/exports description))) - (let ((n (vector-length bindings))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (let ((binding (vector-ref bindings i))) - (link-variables (find-package-environment (vector-ref binding 1)) - (if (fix:= (vector-length binding) 3) - (vector-ref binding 2) - (vector-ref binding 0)) - environment - (vector-ref binding 0)))))) - (let ((bindings (package-description/imports description))) - (let ((n (vector-length bindings))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (let ((binding (vector-ref bindings i))) - (let ((source-environment - (find-package-environment (vector-ref binding 1))) - (source-name - (if (fix:>= (vector-length binding) 3) - (vector-ref binding 2) - (vector-ref binding 0)))) - (guarantee-binding source-environment source-name) - (link-variables environment (vector-ref binding 0) - source-environment source-name))))))))) - (->environment '(package)))) - -(add-subsystem-identification! "CREF" '(2 4)) \ No newline at end of file +(add-subsystem-identification! "CREF" '(2 5)) \ No newline at end of file diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm index 9367a8015..bd544837d 100644 --- a/src/runtime/bytevector.scm +++ b/src/runtime/bytevector.scm @@ -71,10 +71,7 @@ USA. (%legacy-string->bytevector string)))) (define-integrable (%legacy-string->bytevector string) - (object-new-type bytevector-type string)) - -;;; TODO(cph): eliminate after 9.3 release: -(define-integrable bytevector-type #x33) + (object-new-type (ucode-type bytevector) string)) (define (bytevector-append . bytevectors) (let* ((k diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm new file mode 100644 index 000000000..bc8da4741 --- /dev/null +++ b/src/runtime/host-adapter.scm @@ -0,0 +1,103 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Adapt host system. +;;; package: (user) + +(declare (usual-integrations)) + +;;; This file is loaded by the cross-syntaxer and cross-compiler to +;;; hack the host e.g. to add bindings that were added to the new +;;; runtime AND used in the new CREF/SF/LIAR. It is NOT loaded into +;;; the new runtime. It contains temporary hacks that will be kept +;;; only until the new runtime is released. They assume the host is +;;; the current release (9.2 as of March 2017). + +(let ((env (->environment '()))) + (eval ' +(define random-bytevector random-byte-vector) env) + (eval ' +(define (guarantee predicate object #!optional caller) + (if (not (predicate object)) + (error "Not a:" predicate object))) env) + (eval ' +(define (microcode-type name) + (or (microcode-type/name->code name) + (cond ((eq? name 'bytevector) #x33) + ((eq? name 'tagged) #x25) + (else #t)) + (error "MICROCODE-TYPE: Unknown name" name))) env)) + +;; Make new CREF's .pkds usable. +(let ((env (->environment '(package)))) + (eval ' +(define (link-description? object) + (and (vector? object) + (cond ((fix:= (vector-length object) 2) + (and (symbol? (vector-ref object 0)) + (package-name? (vector-ref object 1)))) + ((fix:= (vector-length object) 3) + (and (symbol? (vector-ref object 0)) + (package-name? (vector-ref object 1)) + (symbol? (vector-ref object 2)))) + ((fix:= (vector-length object) 4) + (and (symbol? (vector-ref object 0)) + (package-name? (vector-ref object 1)) + (symbol? (vector-ref object 2)) + (or (eq? #f (vector-ref object 3)) + (eq? 'deprecated (vector-ref object 3))))) + (else #f)))) + env) + (eval ' +(define (create-links-from-description description) + (let ((environment + (find-package-environment (package-description/name description)))) + (let ((bindings (package-description/exports description))) + (let ((n (vector-length bindings))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (let ((binding (vector-ref bindings i))) + (link-variables (find-package-environment (vector-ref binding 1)) + (if (fix:= (vector-length binding) 3) + (vector-ref binding 2) + (vector-ref binding 0)) + environment + (vector-ref binding 0)))))) + (let ((bindings (package-description/imports description))) + (let ((n (vector-length bindings))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (let ((binding (vector-ref bindings i))) + (let ((source-environment + (find-package-environment (vector-ref binding 1))) + (source-name + (if (fix:>= (vector-length binding) 3) + (vector-ref binding 2) + (vector-ref binding 0)))) + (guarantee-binding source-environment source-name) + (link-variables environment (vector-ref binding 0) + source-environment source-name)))))))) + env)) \ No newline at end of file diff --git a/src/runtime/predicate-tagging.scm b/src/runtime/predicate-tagging.scm index a1d36527f..99552ee0c 100644 --- a/src/runtime/predicate-tagging.scm +++ b/src/runtime/predicate-tagging.scm @@ -29,11 +29,8 @@ USA. (declare (usual-integrations)) -;;; TODO(cph): eliminate after 9.3 release: -(define-integrable tagged-object-type #x25) - (define (tagged-object? object) - (fix:= tagged-object-type (object-type object))) + (fix:= (ucode-type tagged) (object-type object))) (define (object-tagger predicate) (let ((tag (predicate->tag predicate))) @@ -47,7 +44,7 @@ USA. (tag->predicate (tagged-object-tag object))) (define-integrable (make-tagged-object tag datum) - (system-pair-cons tagged-object-type tag datum)) + (system-pair-cons (ucode-type tagged) tag datum)) (define (tagged-object-tag object) (guarantee tagged-object? object 'tagged-object-tag) -- 2.25.1