From 2fc54d872b1d3dcd3c368db708ca82e2b93b6d89 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 8 Jan 2018 20:31:07 -0500 Subject: [PATCH] Move all of the generic-procedure support from runtime into sos. It's slated to be entirely replaced by predicate dispatchers. --- src/runtime/ed-ffi.scm | 9 +- src/runtime/gentag.scm | 149 +++++++++++++++-- src/runtime/make.scm | 16 +- src/runtime/predicate-metadata.scm | 1 - src/runtime/record.scm | 121 +++++++++++++- src/runtime/recslot.scm | 209 ------------------------ src/runtime/runtime.pkg | 92 ++--------- src/runtime/swank.scm | 3 +- src/runtime/unpars.scm | 114 ++++++------- src/sos/compile.scm | 5 + src/sos/ed-ffi.scm | 7 +- src/{runtime => sos}/geneqht.scm | 22 +-- src/{runtime => sos}/generic.scm | 190 +++------------------ src/{runtime => sos}/genmult.scm | 40 ++--- src/sos/recslot.scm | 122 ++++++++++++++ src/sos/sos.pkg | 92 ++++++++++- src/{runtime => sos}/tvector.scm | 16 +- tests/check.scm | 2 +- tests/{runtime => sos}/test-genmult.scm | 2 + 19 files changed, 584 insertions(+), 628 deletions(-) delete mode 100644 src/runtime/recslot.scm rename src/{runtime => sos}/geneqht.scm (92%) rename src/{runtime => sos}/generic.scm (61%) rename src/{runtime => sos}/genmult.scm (87%) create mode 100644 src/sos/recslot.scm rename src/{runtime => sos}/tvector.scm (88%) rename tests/{runtime => sos}/test-genmult.scm (99%) diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index ea05763f3..ad7e1ecb9 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -77,13 +77,10 @@ USA. ("gcstat" (runtime gc-statistics)) ("gdatab" (runtime global-database)) ("gdbm" (runtime gdbm)) - ("gencache" (runtime generic-procedure)) - ("geneqht" (runtime generic-procedure)) - ("generic" (runtime generic-procedure)) + ("gencache" (runtime tagged-dispatch)) ("genio" (runtime generic-i/o-port)) - ("genmult" (runtime generic-procedure multiplexer)) ("gensym" (runtime gensym)) - ("gentag" (runtime generic-procedure)) + ("gentag" (runtime tagged-dispatch)) ("global" (runtime miscellaneous-global)) ("graphics" (runtime graphics)) ("hash" (runtime hash)) @@ -136,7 +133,6 @@ USA. ("random" (runtime random-number)) ("rbtree" (runtime rb-tree)) ("record" (runtime record)) - ("recslot" (runtime record-slot-access)) ("regexp" (runtime regular-expression)) ("regsexp" (runtime regular-sexpression)) ("rep" (runtime rep)) @@ -180,7 +176,6 @@ USA. ("thread-queue" (runtime thread-queue)) ("tscript" (runtime transcript)) ("ttyio" (runtime console-i/o-port)) - ("tvector" (runtime tagged-vector)) ("udata" (runtime microcode-data)) ("uenvir" (runtime environment)) ("uerror" (runtime microcode-errors)) diff --git a/src/runtime/gentag.scm b/src/runtime/gentag.scm index b07004af1..f54fd29e9 100644 --- a/src/runtime/gentag.scm +++ b/src/runtime/gentag.scm @@ -24,7 +24,7 @@ USA. |# -;;;; Tags for Generic Procedure Dispatch +;;;; Tags for efficient dispatching ;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis ;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and @@ -80,15 +80,138 @@ USA. ;; primary cache locations from multiple tags. 4) -(define get-dispatch-tag-cache-number) - -(define (initialize-tag-constants!) - (set! get-dispatch-tag-cache-number - (let ((modulus - (int:quotient - (let loop ((n 2)) (if (fix:fixnum? n) (loop (int:* n 2)) n)) - dispatch-tag-cache-number-adds-ok)) - (state (make-random-state))) - (lambda () - (random modulus state)))) - unspecific) \ No newline at end of file +(define-deferred get-dispatch-tag-cache-number + (let ((modulus + (int:quotient + (let loop ((n 2)) (if (fix:fixnum? n) (loop (int:* n 2)) n)) + dispatch-tag-cache-number-adds-ok)) + (state (make-random-state))) + (lambda () + (random modulus state)))) + +;;;; Object Tags + +;;; We assume that most new data types will be constructed from tagged +;;; vectors, and therefore we should optimize the path for such +;;; structures as much as possible. + +(define (dispatch-tag object) + (declare (integrate object)) + (declare (ignore-reference-traps (set microcode-type-tag-table + microcode-type-method-table))) + (if (and (%record? object) + (%record? (%record-ref object 0)) + (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0))) + (%record-ref object 0) + (if (vector-ref microcode-type-tag-table (object-type object)) + (vector-ref microcode-type-tag-table (object-type object)) + ((vector-ref microcode-type-method-table (object-type object)) + object)))) + +(define (make-built-in-tag names) + (let ((tags (map built-in-dispatch-tag names))) + (if (any (lambda (tag) tag) tags) + (let ((tag (car tags))) + (if (not (and (every (lambda (tag*) + (eq? tag* tag)) + (cdr tags)) + (let ((names* (dispatch-tag-contents tag))) + (and (every (lambda (name) + (memq name names*)) + names) + (every (lambda (name) + (memq name names)) + names*))))) + (error "Illegal built-in tag redefinition:" names)) + tag) + (let ((tag (make-dispatch-tag (list-copy names)))) + (set! built-in-tags (cons tag built-in-tags)) + tag)))) + +(define (built-in-dispatch-tags) + (list-copy built-in-tags)) + +(define (built-in-dispatch-tag name) + (find (lambda (tag) + (memq name (dispatch-tag-contents tag))) + built-in-tags)) + +;;;; Initialization + +(define built-in-tags) +(define microcode-type-tag-table) +(define microcode-type-method-table) + +(define (initialize-tag-tables!) + (set! built-in-tags '()) + (set! microcode-type-tag-table + (make-initialized-vector (microcode-type/code-limit) + (lambda (code) + (make-built-in-tag + (let ((names (microcode-type/code->names code))) + (if (pair? names) + names + '(object))))))) + (set! microcode-type-method-table + (make-vector (microcode-type/code-limit) #f)) + + (let ((defmethod + (lambda (name get-method) + (let ((code (microcode-type/name->code name))) + (vector-set! microcode-type-method-table code + (get-method + (vector-ref microcode-type-tag-table code))) + (vector-set! microcode-type-tag-table code #f))))) + (defmethod 'compiled-entry + (lambda (default-tag) + (let ((procedure-tag (make-built-in-tag '(compiled-procedure))) + (return-tag (make-built-in-tag '(compiled-return-address))) + (expression-tag (make-built-in-tag '(compiled-expression)))) + (lambda (object) + (case (system-hunk3-cxr0 + ((ucode-primitive compiled-entry-kind 1) object)) + ((0) procedure-tag) + ((1) return-tag) + ((2) expression-tag) + (else default-tag)))))) + (defmethod 'false + (lambda (default-tag) + (let ((boolean-tag (make-built-in-tag '(boolean)))) + (lambda (object) + (if (eq? object #f) + boolean-tag + default-tag))))) + (defmethod 'constant + (lambda (default-tag) + (let ((boolean-tag (make-built-in-tag '(boolean))) + (null-tag (make-built-in-tag '(null))) + (eof-tag (make-built-in-tag '(eof))) + (default-object-tag (make-built-in-tag '(default))) + (keyword-tag (make-built-in-tag '(lambda-keyword)))) + (lambda (object) + (if (eof-object? object) + eof-tag + (case object + ((#t) boolean-tag) + ((()) null-tag) + ((#!default) default-object-tag) + ((#!optional #!rest #!key #!aux) keyword-tag) + (else default-tag))))))) + (defmethod 'record + (lambda (default-tag) + (let ((dt-tag (make-built-in-tag '(dispatch-tag)))) + (lambda (object) + (if (eq? dispatch-tag-marker (%record-ref object 0)) + dt-tag + default-tag))))) + + ;; Flonum length can change size on different architectures, so we + ;; measure one. + (let ((flonum-length (system-vector-length microcode-id/floating-epsilon))) + (defmethod 'flonum + (lambda (default-tag) + (let ((flonum-vector-tag (make-built-in-tag '(flonum-vector)))) + (lambda (object) + (if (fix:= flonum-length (system-vector-length object)) + default-tag + flonum-vector-tag)))))))) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index caf8aaed6..55dab5b70 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -367,7 +367,7 @@ USA. ("uproc" . (RUNTIME PROCEDURE)) ("fixart" . (RUNTIME FIXNUM-ARITHMETIC)) ("random" . (RUNTIME RANDOM-NUMBER)) - ("gentag" . (RUNTIME GENERIC-PROCEDURE)) + ("gentag" . (runtime tagged-dispatch)) ("thread-low" . (RUNTIME THREAD)) ("poplat" . (RUNTIME POPULATION)) ("record" . (RUNTIME RECORD)))) @@ -405,8 +405,7 @@ USA. (package-initialize '(RUNTIME GC-DAEMONS) #f #t) (package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t) (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t) - (package-initialize '(RUNTIME GENERIC-PROCEDURE) 'INITIALIZE-TAG-CONSTANTS! - #t) + (package-initialize '(runtime tagged-dispatch) #f #t) (package-initialize '(RUNTIME POPULATION) #f #t) (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t) @@ -487,21 +486,14 @@ USA. (RUNTIME SCODE-WALKER) (RUNTIME CONTINUATION-PARSER) (RUNTIME PROGRAM-COPIER) - ;; Generic Procedures - ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING!) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES!) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER!) - ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR!) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS!) + ;; Finish records + ((runtime tagged-dispatch) initialize-tag-tables!) ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!) ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!) ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!) ;; Condition System (RUNTIME ERROR-HANDLER) (RUNTIME MICROCODE-ERRORS) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS!) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS!) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS!) ((RUNTIME STREAM) INITIALIZE-CONDITIONS!) ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!) ;; System dependent stuff diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm index 7938785b3..4574de8ed 100644 --- a/src/runtime/predicate-metadata.scm +++ b/src/runtime/predicate-metadata.scm @@ -292,7 +292,6 @@ USA. (register-predicate! compiled-procedure? 'compiled-procedure '<= procedure?) (register-predicate! entity? 'entity '<= procedure?) (register-predicate! record-entity? 'record-entity '<= entity?) - (register-predicate! generic-procedure? 'generic-procedure '<= procedure?) (register-predicate! memoizer? 'memoizer '<= apply-hook?) (register-predicate! primitive-procedure? 'primitive-procedure '<= procedure?) diff --git a/src/runtime/record.scm b/src/runtime/record.scm index 2093dc393..b59e068fd 100644 --- a/src/runtime/record.scm +++ b/src/runtime/record.scm @@ -43,9 +43,14 @@ USA. (primitive-object-set-type 2) (vector-cons 2)) -(define-integrable (%make-record tag length) - (let ((record ((ucode-primitive object-set-type) - (ucode-type record) (vector-cons length #f)))) +(define (%make-record tag length #!optional init-value) + (let ((record + ((ucode-primitive object-set-type) + (ucode-type record) + (vector-cons length + (if (default-object? init-value) + #f + init-value))))) (%record-set! record 0 tag) record)) @@ -169,6 +174,10 @@ USA. (define-integrable (%record-type-length record-type) (fix:+ 1 (%record-type-n-fields record-type))) +(define-integrable (%record-type-field-name record-type index) + (vector-ref (%record-type-field-names record-type) + (fix:- index 1))) + (define (record-type-dispatch-tag record-type) (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG) (%record-type-dispatch-tag record-type)) @@ -182,7 +191,7 @@ USA. ;; Can't use VECTOR->LIST here because it isn't available at cold load. (let ((v (%record-type-field-names record-type))) ((ucode-primitive subvector->list) v 0 (vector-length v)))) - + (define (record-type-default-inits record-type) (guarantee-record-type record-type 'RECORD-TYPE-DEFAULT-INITS) (vector->list (%record-type-default-inits record-type))) @@ -809,4 +818,106 @@ USA. (define-integrable (check-list-untagged structure type) (if (not (eq? (list?->length structure) (structure-type/length type))) - (error:wrong-type-argument structure type #f))) \ No newline at end of file + (error:wrong-type-argument structure type #f))) + +;;;; Conditions + +(define condition-type:slot-error) +(define condition-type:uninitialized-slot) +(define condition-type:no-such-slot) +(define error:uninitialized-slot) +(define error:no-such-slot) + +(define (initialize-conditions!) + (set! condition-type:slot-error + (make-condition-type 'SLOT-ERROR condition-type:cell-error + '() + (lambda (condition port) + (write-string "Anonymous error for slot " port) + (write (access-condition condition 'LOCATION) port) + (write-string "." port)))) + (set! condition-type:uninitialized-slot + (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error + '(RECORD) + (lambda (condition port) + (write-string "Attempt to reference slot " port) + (write (access-condition condition 'LOCATION) port) + (write-string " in record " port) + (write (access-condition condition 'RECORD) port) + (write-string " failed because the slot is not initialized." + port)))) + (set! condition-type:no-such-slot + (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error + '(RECORD-TYPE) + (lambda (condition port) + (write-string "No slot named " port) + (write (access-condition condition 'LOCATION) port) + (write-string " in records of type " port) + (write (access-condition condition 'RECORD-TYPE) port) + (write-string "." port)))) + (set! error:uninitialized-slot + (let ((signal + (condition-signaller condition-type:uninitialized-slot + '(RECORD LOCATION) + standard-error-handler))) + (lambda (record index) + (let* ((location (%record-field-name record index)) + (ls (write-to-string location))) + (call-with-current-continuation + (lambda (k) + (store-value-restart ls + (lambda (value) + (%record-set! record index value) + (k value)) + (lambda () + (use-value-restart + (string-append + "value to use instead of the contents of slot " + ls) + k + (lambda () (signal record location))))))))))) + (set! error:no-such-slot + (let ((signal + (condition-signaller condition-type:no-such-slot + '(RECORD-TYPE LOCATION) + standard-error-handler))) + (lambda (record-type name) + (call-with-current-continuation + (lambda (k) + (use-value-restart + (string-append "slot name to use instead of " + (write-to-string name)) + k + (lambda () (signal record-type name)))))))) + unspecific) + +(define (%record-field-name record index) + (or (and (fix:> index 0) + (record? record) + (let ((names + (%record-type-field-names (%record-type-descriptor record)))) + (and (fix:<= index (vector-length names)) + (vector-ref names (fix:- index 1))))) + index)) + +(define (record-type-field-name record-type index) + (guarantee record-type? record-type 'record-type-field-name) + (%record-type-field-name record-type index)) + +(define (store-value-restart location k thunk) + (let ((location (write-to-string location))) + (with-restart 'store-value + (string-append "Initialize slot " location " to a given value.") + k + (string->interactor (string-append "Set " location " to")) + thunk))) + +(define (use-value-restart noun-phrase k thunk) + (with-restart 'use-value + (string-append "Specify a " noun-phrase ".") + k + (string->interactor (string-titlecase noun-phrase)) + thunk)) + +(define ((string->interactor string)) + (values (prompt-for-evaluated-expression string))) \ No newline at end of file diff --git a/src/runtime/recslot.scm b/src/runtime/recslot.scm deleted file mode 100644 index e82f630e8..000000000 --- a/src/runtime/recslot.scm +++ /dev/null @@ -1,209 +0,0 @@ -#| -*-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. - -|# - -;;;; Record Slot Access - -(declare (usual-integrations)) - -(define (%record-accessor-generator name) - (lambda (generic tags) - generic - (let ((index (%record-slot-index (%record (car tags)) name))) - (and index - (%record-accessor index))))) - -(define (%record-modifier-generator name) - (lambda (generic tags) - generic - (let ((index (%record-slot-index (%record (car tags)) name))) - (and index - (%record-modifier index))))) - -(define (%record-initpred-generator name) - (lambda (generic tags) - generic - (let ((index (%record-slot-index (%record (car tags)) name))) - (and index - (%record-initpred index))))) - -(define-syntax generate-index-cases - (sc-macro-transformer - (lambda (form environment) - (let ((index (close-syntax (cadr form) environment)) - (limit (caddr form)) - (expand-case (close-syntax (cadddr form) environment))) - `(CASE ,index - ,@(let loop ((i 1)) - (if (= i limit) - `((ELSE (,expand-case ,index))) - `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))))) - -(define (%record-accessor index) - (generate-index-cases index 16 - (lambda (index) - (declare (integrate index) - (ignore-reference-traps (set record-slot-uninitialized))) - (lambda (record) - (if (eq? record-slot-uninitialized (%record-ref record index)) - (error:uninitialized-slot record index) - (%record-ref record index)))))) - -(define (%record-modifier index) - (generate-index-cases index 16 - (lambda (index) - (declare (integrate index)) - (lambda (record value) (%record-set! record index value))))) - -(define (%record-initpred index) - (generate-index-cases index 16 - (lambda (index) - (declare (integrate index) - (ignore-reference-traps (set record-slot-uninitialized))) - (lambda (record) - (not (eq? record-slot-uninitialized (%record-ref record index))))))) - -(define (%record-slot-name record index) - (if (not (and (exact-integer? index) (positive? index))) - (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME)) - (let ((names - (call-with-current-continuation - (lambda (k) - (bind-condition-handler (list condition-type:no-applicable-methods) - (lambda (condition) condition (k 'UNKNOWN)) - (lambda () - (%record-slot-names record)))))) - (index (- index 1))) - (and (list? names) - (< index (length names)) - (list-ref names index)))) - -(define %record-slot-index) -(define %record-slot-names) - -(define (initialize-record-slot-access!) - (set! %record-slot-index (make-generic-procedure 2 '%RECORD-SLOT-INDEX)) - (add-generic-procedure-generator %record-slot-index - (lambda (generic tags) - generic - (and (record-type? (dispatch-tag-contents (car tags))) - (lambda (record name) - (record-type-field-index (record-type-descriptor record) - name - #f))))) - (set! %record-slot-names (make-generic-procedure 1 '%RECORD-SLOT-NAMES)) - (add-generic-procedure-generator %record-slot-names - (lambda (generic tags) - generic - (and (record-type? (dispatch-tag-contents (car tags))) - (lambda (record) - (record-type-field-names (record-type-descriptor record))))))) - -(define (store-value-restart location k thunk) - (let ((location (write-to-string location))) - (with-restart 'STORE-VALUE - (string-append "Initialize slot " location " to a given value.") - k - (string->interactor (string-append "Set " location " to")) - thunk))) - -(define (use-value-restart noun-phrase k thunk) - (with-restart 'USE-VALUE - (string-append "Specify a " noun-phrase ".") - k - (string->interactor (string-titlecase noun-phrase)) - thunk)) - -(define ((string->interactor string)) - (values (prompt-for-evaluated-expression string))) - -(define condition-type:slot-error) -(define condition-type:uninitialized-slot) -(define condition-type:no-such-slot) -(define error:uninitialized-slot) -(define error:no-such-slot) - -(define (initialize-conditions!) - (set! condition-type:slot-error - (make-condition-type 'SLOT-ERROR condition-type:cell-error - '() - (lambda (condition port) - (write-string "Anonymous error for slot " port) - (write (access-condition condition 'LOCATION) port) - (write-string "." port)))) - (set! condition-type:uninitialized-slot - (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error - '(RECORD) - (lambda (condition port) - (write-string "Attempt to reference slot " port) - (write (access-condition condition 'LOCATION) port) - (write-string " in record " port) - (write (access-condition condition 'RECORD) port) - (write-string " failed because the slot is not initialized." - port)))) - (set! condition-type:no-such-slot - (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error - '(RECORD-TYPE) - (lambda (condition port) - (write-string "No slot named " port) - (write (access-condition condition 'LOCATION) port) - (write-string " in records of type " port) - (write (access-condition condition 'RECORD-TYPE) port) - (write-string "." port)))) - (set! error:uninitialized-slot - (let ((signal - (condition-signaller condition-type:uninitialized-slot - '(RECORD LOCATION) - standard-error-handler))) - (lambda (record index) - (let* ((location (or (%record-slot-name record index) index)) - (ls (write-to-string location))) - (call-with-current-continuation - (lambda (k) - (store-value-restart ls - (lambda (value) - (%record-set! record index value) - (k value)) - (lambda () - (use-value-restart - (string-append - "value to use instead of the contents of slot " - ls) - k - (lambda () (signal record location))))))))))) - (set! error:no-such-slot - (let ((signal - (condition-signaller condition-type:no-such-slot - '(RECORD-TYPE LOCATION) - standard-error-handler))) - (lambda (record-type name) - (call-with-current-continuation - (lambda (k) - (use-value-restart - (string-append "slot name to use instead of " - (write-to-string name)) - k - (lambda () (signal record-type name)))))))) - unspecific) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 089bdb78f..171d75bc0 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3739,6 +3739,9 @@ USA. %record-set! %record-tag %record? + condition-type:no-such-slot + condition-type:slot-error + condition-type:uninitialized-slot copy-record define-structure/default-value define-structure/default-value-by-index @@ -3778,7 +3781,9 @@ USA. set-record-type-entity-unparser-method! set-record-type-extension! set-record-type-unparser-method!) - (export (runtime record-slot-access) + (export (runtime) + error:no-such-slot + error:uninitialized-slot record-type-field-index) (export (runtime unparser) structure-tag/entity-unparser-method @@ -5143,90 +5148,15 @@ USA. gdbm_wrcreat gdbm_writer)) -(define-package (runtime generic-procedure) - (files "gentag" "gencache" "generic") +(define-package (runtime tagged-dispatch) + (files "gentag" "gencache") (parent (runtime)) (export () - dispatch-tag-contents - dispatch-tag? - make-dispatch-tag - - ;; generic.scm: built-in-dispatch-tag - built-in-dispatch-tags - condition-type:no-applicable-methods dispatch-tag - error:no-applicable-methods - generic-procedure-applicable? - generic-procedure-arity - generic-procedure-arity-max - generic-procedure-arity-min - generic-procedure-name - generic-procedure? - guarantee-generic-procedure - make-generic-procedure - purge-generic-procedure-cache - standard-generic-procedure-tag) - (export (runtime generic-procedure multiplexer) - generic-procedure-generator - set-generic-procedure-generator!)) - -(define-package (runtime generic-procedure multiplexer) - (files "genmult") - (parent (runtime)) - (export () - add-generic-procedure-generator - condition-type:extra-applicable-methods - error:extra-applicable-methods - generic-procedure-default-generator - generic-procedure-generator-list - remove-generic-procedure-generator - remove-generic-procedure-generators - set-generic-procedure-default-generator!)) - -(define-package (runtime tagged-vector) - (files "tvector") - (parent (runtime)) - (export () - guarantee-tagged-vector - make-tagged-vector - record-slot-uninitialized - set-tagged-vector-element! - set-tagged-vector-tag! - tagged-vector - tagged-vector-element - tagged-vector-element-initialized? - tagged-vector-length - tagged-vector-tag - tagged-vector?)) - -(define-package (runtime record-slot-access) - (files "recslot") - (parent (runtime)) - (export () - condition-type:no-such-slot - condition-type:slot-error - condition-type:uninitialized-slot - %record-accessor - %record-accessor-generator - %record-initpred - %record-initpred-generator - %record-modifier - %record-modifier-generator - %record-slot-index - %record-slot-name - %record-slot-names) - (export (runtime record) - error:no-such-slot)) - -(define-package (runtime generic-procedure eqht) - (files "geneqht") - (parent (runtime)) - (export (runtime generic-procedure) - eqht/for-each - eqht/get - eqht/put! - make-eqht)) + dispatch-tag-contents + dispatch-tag? + make-dispatch-tag)) (define-package (runtime crypto) (files "crypto") diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 1ed7c6762..79e8480be 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -883,8 +883,7 @@ swank:xref ((MACRO) `((:macro nil))) (else (let ((v (environment-lookup env symbol))) - `((,(cond ((generic-procedure? v) ':generic-function) - ((procedure? v) ':function) + `((,(cond ((procedure? v) ':function) (else ':variable)) ,v))))))) (apropos-list text env #t)))) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 20248a928..79d7c3849 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -757,40 +757,27 @@ USA. ;;;; Procedures -(define (unparse-procedure procedure context usual-method) - (if (generic-procedure? procedure) - (*unparse-with-brackets 'GENERIC-PROCEDURE procedure context - (let ((name (generic-procedure-name procedure))) - (and name - (lambda (context*) - (*unparse-object name context*))))) - (usual-method))) - (define (unparse/compound-procedure procedure context) - (unparse-procedure procedure context - (lambda () - (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context - (and (get-param:unparse-compound-procedure-names?) - (lambda-components* (procedure-lambda procedure) - (lambda (name required optional rest body) - required optional rest body - (and (not (eq? name lambda-tag:unnamed)) - (lambda (context*) - (*unparse-object name context*)))))))))) + (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context + (and (get-param:unparse-compound-procedure-names?) + (lambda-components* (procedure-lambda procedure) + (lambda (name required optional rest body) + required optional rest body + (and (not (eq? name lambda-tag:unnamed)) + (lambda (context*) + (*unparse-object name context*)))))))) (define (unparse/primitive-procedure procedure context) - (unparse-procedure procedure context - (lambda () - (let ((unparse-name - (lambda (context) - (*unparse-object (primitive-procedure-name procedure) context)))) - (cond ((get-param:unparse-primitives-by-name?) - (unparse-name context)) - ((get-param:unparse-with-maximum-readability?) - (*unparse-readable-hash procedure context)) - (else - (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context - unparse-name))))))) + (let ((unparse-name + (lambda (context) + (*unparse-object (primitive-procedure-name procedure) context)))) + (cond ((get-param:unparse-primitives-by-name?) + (unparse-name context)) + ((get-param:unparse-with-maximum-readability?) + (*unparse-readable-hash procedure context)) + (else + (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context + unparse-name))))) (define (unparse/compiled-entry entry context) (let* ((type (compiled-entry-type entry)) @@ -798,41 +785,36 @@ USA. (closure? (and procedure? (compiled-code-block/manifest-closure? - (compiled-code-address->block entry)))) - (usual-method - (lambda () - (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type) - entry - context - (lambda (context*) - (let ((name (and procedure? (compiled-procedure/name entry)))) - (receive (filename block-number) - (compiled-entry/filename-and-index entry) - (*unparse-char #\( context*) - (if name - (*unparse-string name context*)) - (if filename - (begin - (if name - (*unparse-char #\space context*)) - (*unparse-object (pathname-name filename) context*) - (if block-number - (begin - (*unparse-char #\space context*) - (*unparse-hex block-number context*))))) - (*unparse-char #\) context*))) - (*unparse-char #\space context*) - (*unparse-hex (compiled-entry/offset entry) context*) - (if closure? - (begin - (*unparse-char #\space context*) - (*unparse-datum (compiled-closure->entry entry) - context*))) - (*unparse-char #\space context*) - (*unparse-datum entry context*)))))) - (if procedure? - (unparse-procedure entry context usual-method) - (usual-method)))) + (compiled-code-address->block entry))))) + (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type) + entry + context + (lambda (context*) + (let ((name (and procedure? (compiled-procedure/name entry)))) + (receive (filename block-number) + (compiled-entry/filename-and-index entry) + (*unparse-char #\( context*) + (if name + (*unparse-string name context*)) + (if filename + (begin + (if name + (*unparse-char #\space context*)) + (*unparse-object (pathname-name filename) context*) + (if block-number + (begin + (*unparse-char #\space context*) + (*unparse-hex block-number context*))))) + (*unparse-char #\) context*))) + (*unparse-char #\space context*) + (*unparse-hex (compiled-entry/offset entry) context*) + (if closure? + (begin + (*unparse-char #\space context*) + (*unparse-datum (compiled-closure->entry entry) + context*))) + (*unparse-char #\space context*) + (*unparse-datum entry context*))))) ;;;; Miscellaneous diff --git a/src/sos/compile.scm b/src/sos/compile.scm index bcb2c8674..b02bbb56a 100644 --- a/src/sos/compile.scm +++ b/src/sos/compile.scm @@ -28,9 +28,14 @@ USA. (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () (compile-file "class") + (compile-file "geneqht") + (compile-file "generic") + (compile-file "genmult") (compile-file "instance") (compile-file "macros") (compile-file "method") (compile-file "printer") + (compile-file "recslot") (compile-file "slot") + (compile-file "tvector") (cref/generate-constructors "sos" 'ALL))) \ No newline at end of file diff --git a/src/sos/ed-ffi.scm b/src/sos/ed-ffi.scm index e326f9e6b..02db4583c 100644 --- a/src/sos/ed-ffi.scm +++ b/src/sos/ed-ffi.scm @@ -29,8 +29,13 @@ USA. (standard-scheme-find-file-initialization '#( ("class" (sos class)) + ("geneqht" (sos generic-procedure eqht)) + ("generic" (sos generic-procedure)) + ("genmult" (sos generic-procedure multiplexer)) ("instance" (sos instance)) ("macros" (sos macros)) ("method" (sos method)) ("printer" (sos printer)) - ("slot" (sos slot)))) \ No newline at end of file + ("recslot" (sos record-slot-access)) + ("slot" (sos slot)) + ("tvector" (sos tagged-vector)))) \ No newline at end of file diff --git a/src/runtime/geneqht.scm b/src/sos/geneqht.scm similarity index 92% rename from src/runtime/geneqht.scm rename to src/sos/geneqht.scm index a8bdd2c8b..eaf44bb2b 100644 --- a/src/runtime/geneqht.scm +++ b/src/sos/geneqht.scm @@ -86,16 +86,6 @@ USA. (without-interruption (lambda () (rehash-table! table))) (loop)))))) -(define-integrable (eq-hash-mod key modulus) - (fix:remainder (let ((n - ((ucode-primitive primitive-object-set-type) - (ucode-type positive-fixnum) - key))) - (if (fix:< n 0) - (fix:not n) - n)) - modulus)) - (define (record-address-hash-table! table) (add-to-population! address-hash-tables table)) @@ -104,11 +94,8 @@ USA. (lambda (table) (set-table-needs-rehash?! table #t)))) -(define address-hash-tables) - -(define (initialize-address-hashing!) - (set! address-hash-tables (make-serial-population)) - (add-primitive-gc-daemon! mark-address-hash-tables!)) +(define address-hash-tables (make-serial-population)) +(add-primitive-gc-daemon! mark-address-hash-tables!) ;;;; Resizing @@ -229,7 +216,4 @@ USA. (primes prime-numbers-stream) (needs-rehash? #f)) -(define-integrable minimum-size 4) - -(define-integrable (weak-cons car cdr) - (system-pair-cons (ucode-type weak-cons) car cdr)) \ No newline at end of file +(define-integrable minimum-size 4) \ No newline at end of file diff --git a/src/runtime/generic.scm b/src/sos/generic.scm similarity index 61% rename from src/runtime/generic.scm rename to src/sos/generic.scm index 5f84e8ba4..798f6b8a5 100644 --- a/src/runtime/generic.scm +++ b/src/sos/generic.scm @@ -25,10 +25,9 @@ USA. |# ;;;; Generic Procedures -;;; package: (runtime generic-procedure) +;;; package: (sos generic-procedure) -(declare (usual-integrations) - (integrate-external "gentag" "gencache")) +(declare (usual-integrations)) ;;;; Generic Procedures @@ -289,169 +288,22 @@ USA. (fill-cache (generic-record/cache record) tags procedure)))) (apply procedure args)))) -;;;; Object Tags - -;;; We assume that most new data types will be constructed from tagged -;;; vectors, and therefore we should optimize the path for such -;;; structures as much as possible. - -(define (dispatch-tag object) - (declare (integrate object)) - (declare (ignore-reference-traps (set microcode-type-tag-table - microcode-type-method-table))) - (if (and (%record? object) - (%record? (%record-ref object 0)) - (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0))) - (%record-ref object 0) - (if (vector-ref microcode-type-tag-table (object-type object)) - (vector-ref microcode-type-tag-table (object-type object)) - ((vector-ref microcode-type-method-table (object-type object)) - object)))) - -(define (make-built-in-tag names) - (let ((tags (map built-in-dispatch-tag names))) - (if (any (lambda (tag) tag) tags) - (let ((tag (car tags))) - (if (not (and (every (lambda (tag*) - (eq? tag* tag)) - (cdr tags)) - (let ((names* (dispatch-tag-contents tag))) - (and (every (lambda (name) - (memq name names*)) - names) - (every (lambda (name) - (memq name names)) - names*))))) - (error "Illegal built-in tag redefinition:" names)) - tag) - (let ((tag (make-dispatch-tag (list-copy names)))) - (set! built-in-tags (cons tag built-in-tags)) - tag)))) - -(define (built-in-dispatch-tags) - (list-copy built-in-tags)) - -(define (built-in-dispatch-tag name) - (find-matching-item built-in-tags - (lambda (tag) - (memq name (dispatch-tag-contents tag))))) - -(define condition-type:no-applicable-methods) -(define error:no-applicable-methods) - -(define (initialize-conditions!) - (set! condition-type:no-applicable-methods - (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error - '(OPERATOR OPERANDS) - (lambda (condition port) - (write-string "No applicable methods for " port) - (write (access-condition condition 'OPERATOR) port) - (write-string " with these arguments: " port) - (write (access-condition condition 'OPERANDS) port) - (write-string "." port)))) - (set! error:no-applicable-methods - (condition-signaller condition-type:no-applicable-methods - '(OPERATOR OPERANDS) - standard-error-handler)) - unspecific) - -;;;; Initialization - -(define standard-generic-procedure-tag) -(define generic-procedure-records) -(define generic-procedure-records-mutex) -(define built-in-tags) -(define microcode-type-tag-table) -(define microcode-type-method-table) - -(define (initialize-generic-procedures!) - (set! standard-generic-procedure-tag - (make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE)) - (set! generic-procedure-records (make-eqht)) - (set! generic-procedure-records-mutex (make-thread-mutex)) - - ;; Initialize the built-in tag tables. - (set! built-in-tags '()) - (set! microcode-type-tag-table - (make-initialized-vector (microcode-type/code-limit) - (lambda (code) - (make-built-in-tag - (let ((names (microcode-type/code->names code))) - (if (pair? names) - names - '(OBJECT))))))) - (set! microcode-type-method-table - (make-vector (microcode-type/code-limit) #f)) - (let ((assign-type - (lambda (name get-method) - (let ((code (microcode-type/name->code name))) - (vector-set! microcode-type-method-table code - (get-method - (vector-ref microcode-type-tag-table code))) - (vector-set! microcode-type-tag-table code #f))))) - (define-integrable (maybe-generic object default-tag) - (let ((record (with-thread-mutex-lock generic-procedure-records-mutex - (lambda () - (eqht/get generic-procedure-records object #f))))) - (if record - (generic-record/tag record) - default-tag))) - (let ((procedure-type - (lambda (default-tag) - (lambda (object) - (maybe-generic object default-tag))))) - (assign-type 'EXTENDED-PROCEDURE procedure-type) - (assign-type 'PROCEDURE procedure-type)) - (assign-type - 'COMPILED-ENTRY - (let ((procedure-tag (make-built-in-tag '(COMPILED-PROCEDURE))) - (return-address-tag (make-built-in-tag '(COMPILED-RETURN-ADDRESS))) - (expression-tag (make-built-in-tag '(COMPILED-EXPRESSION)))) - (lambda (default-tag) - (lambda (object) - (case (system-hunk3-cxr0 - ((ucode-primitive compiled-entry-kind 1) object)) - ((0) (maybe-generic object procedure-tag)) - ((1) return-address-tag) - ((2) expression-tag) - (else default-tag)))))) - (let ((boolean-tag (make-built-in-tag '(BOOLEAN)))) - (assign-type 'FALSE - (lambda (default-tag) - (lambda (object) - (if (eq? object #f) - boolean-tag - default-tag)))) - (assign-type 'CONSTANT - (let ((null-tag (make-built-in-tag '(NULL))) - (eof-tag (make-built-in-tag '(EOF))) - (default-tag (make-built-in-tag '(DEFAULT))) - (keyword-tag (make-built-in-tag '(LAMBDA-KEYWORD)))) - (lambda (constant-tag) - (lambda (object) - (cond ((eq? object #t) boolean-tag) - ((null? object) null-tag) - ((eof-object? object) eof-tag) - ((default-object? object) default-tag) - ((memq object '(#!optional #!rest #!key #!aux)) - keyword-tag) - (else constant-tag))))))) - - ;; Flonum length can change size on different architectures, so we - ;; measure one. - (let ((flonum-length (system-vector-length microcode-id/floating-epsilon))) - (assign-type 'FLONUM - (let ((flonum-vector-tag - (make-built-in-tag '(FLONUM-VECTOR)))) - (lambda (default-tag) - (lambda (object) - (if (fix:= flonum-length (system-vector-length object)) - default-tag - flonum-vector-tag)))))) - (assign-type 'RECORD - (let ((dt-tag (make-built-in-tag '(DISPATCH-TAG)))) - (lambda (default-tag) - (lambda (object) - (if (eq? dispatch-tag-marker (%record-ref object 0)) - dt-tag - default-tag))))))) \ No newline at end of file +(define standard-generic-procedure-tag + (make-dispatch-tag 'standard-generic-procedure)) +(define generic-procedure-records (make-eqht)) +(define generic-procedure-records-mutex (make-thread-mutex)) + +(define condition-type:no-applicable-methods + (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error + '(OPERATOR OPERANDS) + (lambda (condition port) + (write-string "No applicable methods for " port) + (write (access-condition condition 'OPERATOR) port) + (write-string " with these arguments: " port) + (write (access-condition condition 'OPERANDS) port) + (write-string "." port)))) + +(define error:no-applicable-methods + (condition-signaller condition-type:no-applicable-methods + '(OPERATOR OPERANDS) + standard-error-handler)) \ No newline at end of file diff --git a/src/runtime/genmult.scm b/src/sos/genmult.scm similarity index 87% rename from src/runtime/genmult.scm rename to src/sos/genmult.scm index 3ad5e4adc..716c01a7c 100644 --- a/src/runtime/genmult.scm +++ b/src/sos/genmult.scm @@ -166,26 +166,20 @@ USA. (and default (default generic tags)))))) -(define multiplexer-tag) -(define condition-type:extra-applicable-methods) -(define error:extra-applicable-methods) - -(define (initialize-multiplexer!) - (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER)) - unspecific) - -(define (initialize-conditions!) - (set! condition-type:extra-applicable-methods - (make-condition-type 'EXTRA-APPLICABLE-METHODS condition-type:error - '(OPERATOR OPERANDS) - (lambda (condition port) - (write-string "Too many applicable methods for " port) - (write (access-condition condition 'OPERATOR) port) - (write-string " with these arguments: " port) - (write (access-condition condition 'OPERANDS) port) - (write-string "." port)))) - (set! error:extra-applicable-methods - (condition-signaller condition-type:extra-applicable-methods - '(OPERATOR OPERANDS) - standard-error-handler)) - unspecific) \ No newline at end of file +(define multiplexer-tag + (list 'generic-procedure-multiplexer)) + +(define condition-type:extra-applicable-methods + (make-condition-type 'extra-applicable-methods condition-type:error + '(OPERATOR OPERANDS) + (lambda (condition port) + (write-string "Too many applicable methods for " port) + (write (access-condition condition 'operator) port) + (write-string " with these arguments: " port) + (write (access-condition condition 'operands) port) + (write-string "." port)))) + +(define error:extra-applicable-methods + (condition-signaller condition-type:extra-applicable-methods + '(operator operands) + standard-error-handler)) \ No newline at end of file diff --git a/src/sos/recslot.scm b/src/sos/recslot.scm new file mode 100644 index 000000000..eb1ddb5a0 --- /dev/null +++ b/src/sos/recslot.scm @@ -0,0 +1,122 @@ +#| -*-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. + +|# + +;;;; Record Slot Access + +(declare (usual-integrations)) + +(define (%record-accessor-generator name) + (lambda (generic tags) + generic + (let ((index (%record-slot-index (%record (car tags)) name))) + (and index + (%record-accessor index))))) + +(define (%record-modifier-generator name) + (lambda (generic tags) + generic + (let ((index (%record-slot-index (%record (car tags)) name))) + (and index + (%record-modifier index))))) + +(define (%record-initpred-generator name) + (lambda (generic tags) + generic + (let ((index (%record-slot-index (%record (car tags)) name))) + (and index + (%record-initpred index))))) + +(define-syntax generate-index-cases + (sc-macro-transformer + (lambda (form environment) + (let ((index (close-syntax (cadr form) environment)) + (limit (caddr form)) + (expand-case (close-syntax (cadddr form) environment))) + `(CASE ,index + ,@(let loop ((i 1)) + (if (= i limit) + `((ELSE (,expand-case ,index))) + `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))))) + +(define (%record-accessor index) + (generate-index-cases index 16 + (lambda (index) + (declare (integrate index) + (ignore-reference-traps (set record-slot-uninitialized))) + (lambda (record) + (if (eq? record-slot-uninitialized (%record-ref record index)) + (error:uninitialized-slot record index) + (%record-ref record index)))))) + +(define (%record-modifier index) + (generate-index-cases index 16 + (lambda (index) + (declare (integrate index)) + (lambda (record value) (%record-set! record index value))))) + +(define (%record-initpred index) + (generate-index-cases index 16 + (lambda (index) + (declare (integrate index) + (ignore-reference-traps (set record-slot-uninitialized))) + (lambda (record) + (not (eq? record-slot-uninitialized (%record-ref record index))))))) + +(define (%record-slot-name record index) + (if (not (and (exact-integer? index) (positive? index))) + (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME)) + (let ((names + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:no-applicable-methods) + (lambda (condition) condition (k 'UNKNOWN)) + (lambda () + (%record-slot-names record)))))) + (index (- index 1))) + (and (list? names) + (< index (length names)) + (list-ref names index)))) + +(define %record-slot-index + (make-generic-procedure 2 '%record-slot-index)) + +(add-generic-procedure-generator %record-slot-index + (lambda (generic tags) + generic + (and (record-type? (dispatch-tag-contents (car tags))) + (lambda (record name) + (record-type-field-index (record-type-descriptor record) + name + #f))))) +(define %record-slot-names + (make-generic-procedure 1 '%record-slot-names)) + +(add-generic-procedure-generator %record-slot-names + (lambda (generic tags) + generic + (and (record-type? (dispatch-tag-contents (car tags))) + (lambda (record) + (record-type-field-names (record-type-descriptor record)))))) \ No newline at end of file diff --git a/src/sos/sos.pkg b/src/sos/sos.pkg index a33043e0e..27c397418 100644 --- a/src/sos/sos.pkg +++ b/src/sos/sos.pkg @@ -29,7 +29,89 @@ USA. (global-definitions "../runtime/runtime") (define-package (sos) - (parent ())) + (parent (runtime))) + +(define-package (sos generic-procedure eqht) + (files "geneqht") + (parent (sos)) + (export (sos generic-procedure) + eqht/for-each + eqht/get + eqht/put! + make-eqht)) + +(define-package (sos generic-procedure) + (files "generic") + (parent (sos)) + (export () + generic-procedure-applicable? + generic-procedure-arity + generic-procedure-arity-max + generic-procedure-arity-min + generic-procedure-name + generic-procedure? + guarantee-generic-procedure + make-generic-procedure + purge-generic-procedure-cache + standard-generic-procedure-tag) + (export (sos) + condition-type:no-applicable-methods + error:no-applicable-methods) + (export (sos generic-procedure multiplexer) + generic-procedure-generator + set-generic-procedure-generator!) + (import (runtime tagged-dispatch) + fill-cache + new-cache + probe-cache + probe-cache-1 + probe-cache-2 + probe-cache-3 + probe-cache-4 + purge-cache-entries)) + +(define-package (sos generic-procedure multiplexer) + (files "genmult") + (parent (sos)) + (export () + add-generic-procedure-generator + condition-type:extra-applicable-methods + error:extra-applicable-methods + generic-procedure-default-generator + generic-procedure-generator-list + remove-generic-procedure-generator + remove-generic-procedure-generators + set-generic-procedure-default-generator!)) + +(define-package (sos tagged-vector) + (files "tvector") + (parent (sos)) + (export (sos) + guarantee-tagged-vector + make-tagged-vector + record-slot-uninitialized + set-tagged-vector-element! + set-tagged-vector-tag! + tagged-vector + tagged-vector-element + tagged-vector-element-initialized? + tagged-vector-length + tagged-vector-tag + tagged-vector?)) + +(define-package (sos record-slot-access) + (files "recslot") + (parent (sos)) + (export (sos) + %record-accessor + %record-accessor-generator + %record-initpred + %record-initpred-generator + %record-modifier + %record-modifier-generator + %record-slot-index + %record-slot-name + %record-slot-names)) (define-package (sos slot) (files "slot") @@ -56,9 +138,7 @@ USA. (export (sos class) canonicalize-slot-argument compute-slot-descriptor - install-slot-accessor-methods) - (import (runtime record-slot-access) - error:no-such-slot)) + install-slot-accessor-methods)) (define-package (sos class) (files "class") @@ -117,9 +197,7 @@ USA. subclass?) (import (runtime microcode-tables) microcode-type/code->name - microcode-type/name->code) - (import (runtime record-slot-access) - error:no-such-slot)) + microcode-type/name->code)) (define-package (sos instance) (files "instance") diff --git a/src/runtime/tvector.scm b/src/sos/tvector.scm similarity index 88% rename from src/runtime/tvector.scm rename to src/sos/tvector.scm index 60ebdbca2..2b38f5be4 100644 --- a/src/runtime/tvector.scm +++ b/src/sos/tvector.scm @@ -35,16 +35,11 @@ USA. (define (make-tagged-vector tag length) (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) (guarantee-index-integer length 'MAKE-TAGGED-VECTOR) - (let ((result - (object-new-type (ucode-type record) - (make-vector (fix:+ length 1) - record-slot-uninitialized)))) - (%record-set! result 0 tag) - result)) + (%make-record tag (fix:+ length 1) record-slot-uninitialized)) (define (tagged-vector tag . elements) (guarantee dispatch-tag? tag 'MAKE-TAGGED-VECTOR) - (object-new-type (ucode-type record) (apply vector tag elements))) + (apply %record tag elements)) (define (tagged-vector? object) (and (%record? object) @@ -90,8 +85,5 @@ USA. (if (not (and (fix:fixnum? index) (fix:>= index 0))) (error:wrong-type-argument vector "non-negative fixnum" caller))) -(define record-slot-uninitialized) - -(define (initialize-tagged-vector!) - (set! record-slot-uninitialized (intern "#[record-slot-uninitialized]")) - unspecific) \ No newline at end of file +(define record-slot-uninitialized + (intern "#[record-slot-uninitialized]")) \ No newline at end of file diff --git a/tests/check.scm b/tests/check.scm index 9480e5678..8a7dc81c2 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -61,7 +61,6 @@ USA. "runtime/test-ephemeron" ("runtime/test-file-attributes" (runtime)) "runtime/test-floenv" - "runtime/test-genmult" "runtime/test-hash-table" "runtime/test-integer-bits" "runtime/test-md5" @@ -83,6 +82,7 @@ USA. "runtime/test-url" ("runtime/test-wttree" (runtime wt-tree)) ;;"ffi/test-ffi" + "sos/test-genmult" )) (with-working-directory-pathname diff --git a/tests/runtime/test-genmult.scm b/tests/sos/test-genmult.scm similarity index 99% rename from tests/runtime/test-genmult.scm rename to tests/sos/test-genmult.scm index 5eb50b7a3..43762edcb 100644 --- a/tests/runtime/test-genmult.scm +++ b/tests/sos/test-genmult.scm @@ -28,6 +28,8 @@ USA. (declare (usual-integrations)) +(load-option 'sos) + (define-test 'REGRESSION:REMOVE-GENERIC-PROCEDURE-GENERATOR (lambda () (define generic (make-generic-procedure 1)) -- 2.25.1