From e16ca1969c7532c29aea4c8756e9fd0d5527851b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 23 Apr 1996 20:38:03 +0000 Subject: [PATCH] Initial revision --- v7/src/microcode/prgdbm.c | 264 ++++++++++++++++++ v7/src/runtime/gdbm.scm | 143 ++++++++++ v7/src/runtime/gencache.scm | 526 ++++++++++++++++++++++++++++++++++++ v7/src/runtime/geneqht.scm | 258 ++++++++++++++++++ v7/src/runtime/generic.scm | 432 +++++++++++++++++++++++++++++ v7/src/runtime/genmult.scm | 189 +++++++++++++ v7/src/runtime/gentag.scm | 107 ++++++++ v7/src/runtime/recslot.scm | 106 ++++++++ v7/src/runtime/tvector.scm | 106 ++++++++ 9 files changed, 2131 insertions(+) create mode 100644 v7/src/microcode/prgdbm.c create mode 100644 v7/src/runtime/gdbm.scm create mode 100644 v7/src/runtime/gencache.scm create mode 100644 v7/src/runtime/geneqht.scm create mode 100644 v7/src/runtime/generic.scm create mode 100644 v7/src/runtime/genmult.scm create mode 100644 v7/src/runtime/gentag.scm create mode 100644 v7/src/runtime/recslot.scm create mode 100644 v7/src/runtime/tvector.scm diff --git a/v7/src/microcode/prgdbm.c b/v7/src/microcode/prgdbm.c new file mode 100644 index 000000000..aca93b88f --- /dev/null +++ b/v7/src/microcode/prgdbm.c @@ -0,0 +1,264 @@ +/* -*-C-*- + +$Id: prgdbm.c,v 1.1 1996/04/23 20:36:48 cph Exp $ + +Copyright (c) 1996 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. */ + +/* Interface to the gdbm database library */ + +#include "scheme.h" +#include "prims.h" +#include "os.h" +#include + +/* Allocation Tables */ + +struct allocation_table +{ + PTR * items; + int length; +}; + +static void +DEFUN (allocation_table_initialize, (table), struct allocation_table * table) +{ + (table -> length) = 0; +} + +static unsigned int +DEFUN (allocate_table_index, (table, item), + struct allocation_table * table AND + PTR item) +{ + unsigned int length = (table -> length); + unsigned int new_length; + PTR * items = (table -> items); + PTR * new_items; + PTR * scan; + PTR * end; + if (length == 0) + { + new_length = 4; + new_items = (OS_malloc ((sizeof (PTR)) * new_length)); + } + else + { + scan = items; + end = (scan + length); + while (scan < end) + if ((*scan++) == 0) + { + (*--scan) = item; + return (scan - items); + } + new_length = (length * 2); + new_items = (OS_realloc (items, ((sizeof (PTR)) * new_length))); + } + scan = (new_items + length); + end = (new_items + new_length); + (*scan++) = item; + while (scan < end) + (*scan++) = 0; + (table -> items) = new_items; + (table -> length) = new_length; + return (length); +} + +static PTR +DEFUN (allocation_item_arg, (arg, table), + unsigned int arg AND + struct allocation_table * table) +{ + unsigned int index = (arg_ulong_index_integer (arg, (table -> length))); + PTR item = ((table -> items) [index]); + if (item == 0) + error_bad_range_arg (arg); + return (item); +} + +static struct allocation_table dbf_table; + +#define DBF_VAL(dbf) \ + (ulong_to_integer (allocate_table_index ((&dbf_table), ((PTR) (dbf))))) + +#define DBF_ARG(arg) \ + ((GDBM_FILE) (allocation_item_arg ((arg), (&dbf_table)))) + +#define GDBM_ERROR_VAL() \ + (char_pointer_to_string ((unsigned char *) (gdbm_strerror (gdbm_errno)))) + +#define VOID_GDBM_CALL(expression) \ + (((expression) == 0) ? SHARP_F : (GDBM_ERROR_VAL ())) + +static datum +DEFUN (arg_datum, (arg), int arg) +{ + datum d; + CHECK_ARG (arg, STRING_P); + (d . dptr) = ((char *) (STRING_LOC ((ARG_REF (arg)), 0))); + (d . dsize) = (STRING_LENGTH (ARG_REF (arg))); + return (d); +} + +static SCHEME_OBJECT +DEFUN (datum_to_object, (d), datum d) +{ + if (d . dptr) + { + SCHEME_OBJECT result = (allocate_string (d . dsize)); + CONST char * scan_d = (d . dptr); + CONST char * end_d = (scan_d + (d . dsize)); + unsigned char * scan_result = (STRING_LOC (result, 0)); + while (scan_d < end_d) + (*scan_result++) = ((unsigned char) (*scan_d++)); + free (d . dptr); + return (result); + } + else + return (SHARP_F); +} + +static void +DEFUN (gdbm_fatal_error, (msg), char * msg) +{ + fprintf (stderr, "\ngdbm: %s\n", msg); + fflush (stderr); + error_external_return (); +} + +DEFINE_PRIMITIVE ("GDBM-OPEN", Prim_gdbm_open, 4, 4, 0) +{ + static int initialization_done = 0; + PRIMITIVE_HEADER (4); + if (!initialization_done) + { + allocation_table_initialize (&dbf_table); + initialization_done = 1; + } + { + GDBM_FILE dbf = (gdbm_open ((STRING_ARG (1)), + (arg_integer (2)), + (arg_integer (3)), + (arg_integer (4)), + gdbm_fatal_error)); + PRIMITIVE_RETURN ((dbf == 0) ? (GDBM_ERROR_VAL ()) : (DBF_VAL (dbf))); + } +} + +DEFINE_PRIMITIVE ("GDBM-CLOSE", Prim_gdbm_close, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + gdbm_close (DBF_ARG (1)); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("GDBM-STORE", Prim_gdbm_store, 4, 4, 0) +{ + PRIMITIVE_HEADER (4); + { + int result = (gdbm_store ((DBF_ARG (1)), + (arg_datum (2)), + (arg_datum (3)), + (arg_integer (4)))); + PRIMITIVE_RETURN + ((result < 0) ? (GDBM_ERROR_VAL ()) : (BOOLEAN_TO_OBJECT (!result))); + } +} + +DEFINE_PRIMITIVE ("GDBM-FETCH", Prim_gdbm_fetch, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (datum_to_object (gdbm_fetch ((DBF_ARG (1)), (arg_datum (2))))); +} + +DEFINE_PRIMITIVE ("GDBM-EXISTS", Prim_gdbm_exists, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (BOOLEAN_TO_OBJECT (gdbm_exists ((DBF_ARG (1)), (arg_datum (2))))); +} + +DEFINE_PRIMITIVE ("GDBM-DELETE", Prim_gdbm_delete, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (((gdbm_delete ((DBF_ARG (1)), (arg_datum (2)))) == 0) + ? SHARP_T + : (gdbm_errno == GDBM_ITEM_NOT_FOUND) + ? SHARP_F + : (GDBM_ERROR_VAL ())); +} + +DEFINE_PRIMITIVE ("GDBM-FIRSTKEY", Prim_gdbm_firstkey, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (datum_to_object (gdbm_firstkey (DBF_ARG (1)))); +} + +DEFINE_PRIMITIVE ("GDBM-NEXTKEY", Prim_gdbm_nextkey, 2, 2, 0) +{ + PRIMITIVE_HEADER (2); + PRIMITIVE_RETURN + (datum_to_object (gdbm_nextkey ((DBF_ARG (1)), (arg_datum (2))))); +} + +DEFINE_PRIMITIVE ("GDBM-REORGANIZE", Prim_gdbm_reorganize, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + PRIMITIVE_RETURN (VOID_GDBM_CALL (gdbm_reorganize (DBF_ARG (1)))); +} + +DEFINE_PRIMITIVE ("GDBM-SYNC", Prim_gdbm_sync, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + gdbm_sync (DBF_ARG (1)); + PRIMITIVE_RETURN (UNSPECIFIC); +} + +DEFINE_PRIMITIVE ("GDBM-VERSION", Prim_gdbm_version, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); + PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) gdbm_version)); +} + +DEFINE_PRIMITIVE ("GDBM-SETOPT", Prim_gdbm_setopt, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + int value = (arg_integer (3)); + PRIMITIVE_RETURN + (VOID_GDBM_CALL (gdbm_setopt ((DBF_ARG (1)), + (arg_integer (2)), + (&value), + (sizeof (int))))); + } +} diff --git a/v7/src/runtime/gdbm.scm b/v7/src/runtime/gdbm.scm new file mode 100644 index 000000000..da2e4075d --- /dev/null +++ b/v7/src/runtime/gdbm.scm @@ -0,0 +1,143 @@ +#| -*-Scheme-*- + +$Id: gdbm.scm,v 1.1 1996/04/23 20:37:04 cph Exp $ + +Copyright (c) 1996 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; gdbm Database Library Interface +;;; package: (runtime gdbm) + +(declare (usual-integrations)) + +(define (gdbm-available?) + (implemented-primitive-procedure? (ucode-primitive gdbm-open 4))) + +;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can +;; create the database. +(define GDBM_READER 0) ;A reader. +(define GDBM_WRITER 1) ;A writer. +(define GDBM_WRCREAT 2) ;A writer. Create the db if needed. +(define GDBM_NEWDB 3) ;A writer. Always create a new db. +(define GDBM_FAST 16) ;Write fast! => No fsyncs. + +(define (gdbm-open filename block-size flags mode) + (let ((filename (->namestring (merge-pathnames filename)))) + (without-interrupts + (lambda () + (let ((descriptor + (gdbm-error ((ucode-primitive gdbm-open 4) + filename block-size flags mode)))) + (let ((gdbf (make-gdbf descriptor filename))) + (add-to-protection-list! gdbf-list gdbf descriptor) + gdbf)))))) + +(define (gdbm-close gdbf) + (if (not (gdbf? gdbf)) + (error:wrong-type-argument gdbf "gdbm handle" 'GDBM-CLOSE)) + (let ((descriptor (gdbf-descriptor gdbf))) + (if descriptor + (without-interrupts + (lambda () + ((ucode-primitive gdbm-close 1) descriptor) + (remove-from-protection-list! gdbf-list gdbf) + (set-gdbf-descriptor! gdbf #f)))))) + +;; Parameters to gdbm_store for simple insertion or replacement in the +;; case that the key is already in the database. +(define GDBM_INSERT 0) ;Never replace old data with new. +(define GDBM_REPLACE 1) ;Always replace old data with new. + +(define (gdbm-store gdbf key datum flags) + (gdbm-error + ((ucode-primitive gdbm-store 4) (guarantee-gdbf gdbf 'GDBM-STORE) + key datum flags))) + +(define (gdbm-fetch gdbf key) + ((ucode-primitive gdbm-fetch 2) (guarantee-gdbf gdbf 'GDBM-FETCH) key)) + +(define (gdbm-exists? gdbf key) + ((ucode-primitive gdbm-exists 2) (guarantee-gdbf gdbf 'GDBM-EXISTS?) key)) + +(define (gdbm-delete gdbf key) + (gdbm-error + ((ucode-primitive gdbm-delete 2) (guarantee-gdbf gdbf 'GDBM-DELETE) key))) + +(define (gdbm-firstkey gdbf) + ((ucode-primitive gdbm-firstkey 1) (guarantee-gdbf gdbf 'GDBM-FIRSTKEY))) + +(define (gdbm-nextkey gdbf key) + ((ucode-primitive gdbm-nextkey 2) (guarantee-gdbf gdbf 'GDBM-NEXTKEY) key)) + +(define (gdbm-reorganize gdbf) + (gdbm-error + ((ucode-primitive gdbm-reorganize 1) + (guarantee-gdbf gdbf 'GDBM-REORGANIZE)))) + +(define (gdbm-sync gdbf) + ((ucode-primitive gdbm-sync 1) (guarantee-gdbf gdbf 'GDBM-SYNC))) + +(define (gdbm-version) + ((ucode-primitive gdbm-version 0))) + +;; Parameters to gdbm_setopt, specifing the type of operation to perform. +(define GDBM_CACHESIZE 1) ;Set the cache size. +(define GDBM_FASTMODE 2) ;Toggle fast mode. + +(define (gdbm-setopt gdbf opt val) + (gdbm-error + ((ucode-primitive gdbm-setopt 3) (guarantee-gdbf gdbf 'GDBM-SETOPT) + opt val))) + +(define-structure (gdbf + (print-procedure (standard-unparser-method 'GDBF + (lambda (gdbf port) + (write-char #\space port) + (write (gdbf-filename gdbf) port))))) + descriptor + (filename #f read-only #t)) + +(define (guarantee-gdbf gdbf procedure) + (if (gdbf? gdbf) + (or (gdbf-descriptor gdbf) (error:bad-range-argument gdbf procedure)) + (error:wrong-type-argument gdbf "gdbm handle" procedure))) + +(define (gdbm-error object) + (if (string? object) (error "gdbm error:" object)) + object) + +(define gdbf-list) +(define (initialize-package!) + (set! gdbf-list (make-protection-list)) + (add-gc-daemon! + (lambda () + (clean-lost-protected-objects gdbf-list (ucode-primitive gdbm-close 1)))) + (add-event-receiver! event:after-restore + (lambda () (drop-all-protected-objects gdbf-list)))) \ No newline at end of file diff --git a/v7/src/runtime/gencache.scm b/v7/src/runtime/gencache.scm new file mode 100644 index 000000000..c75def951 --- /dev/null +++ b/v7/src/runtime/gencache.scm @@ -0,0 +1,526 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: gencache.scm,v 1.1 1996/04/23 20:37:15 cph Exp $ +;;; +;;; Copyright (c) 1993-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Method Caches for Generic Dispatch + +;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis +;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and +;;; Functional Programming. Parts of this code are based on the +;;; September 16, 1992 PCL implementation. + +(declare (usual-integrations) + (integrate-external "gentag")) + +(define-structure (cache (constructor %make-cache)) + (tag-index 0) + (mask 0 read-only #t) + (limit 0 read-only #t) + (n-tags 0 read-only #t) + (tags '#() read-only #t) + (values '#() read-only #t) + (overflow '())) + +(define (new-cache n-tags) + (make-cache dispatch-tag-index-start n-tags 4)) + +(define (make-cache tag-index n-tags length) + ;; LENGTH is assumed to be a power of two. + (%make-cache tag-index + (fix:- length 1) + (cond ((fix:<= length 4) 1) + ((fix:<= length 16) 4) + (else 6)) + n-tags + (make-vector length (make-list n-tags #f)) + (make-vector length #f) + '())) + +(define-integrable (cache-length cache) + (vector-length (cache-tags cache))) + +(define-integrable (cache-line-tags cache line) + (vector-ref (cache-tags cache) line)) + +(define-integrable (set-cache-line-tags! cache line tags) + (vector-set! (cache-tags cache) line tags)) + +(define-integrable (cache-line-value cache line) + (vector-ref (cache-values cache) line)) + +(define-integrable (set-cache-line-value! cache line value) + (vector-set! (cache-values cache) line value)) + +(define-integrable (cache-next-line cache line) + (if (fix:= (fix:+ line 1) (cache-length cache)) + 0 + (fix:+ line 1))) + +(define-integrable (cache-line-separation cache line line*) + (let ((n (fix:- line* line))) + (if (fix:< n 0) + (fix:+ n (cache-length cache)) + n))) + +(define (probe-cache cache tags) + (let ((line (compute-primary-cache-line cache tags))) + (and line + (let ((limit (cache-limit cache))) + (letrec + ((search-lines + (lambda (line i) + (cond ((match (cache-line-tags cache line)) + (cache-line-value cache line)) + ((fix:= i limit) + (search-overflow (cache-overflow cache))) + (else + (search-lines (cache-next-line cache line) + (fix:+ i 1)))))) + (search-overflow + (lambda (overflow) + (and (not (null? overflow)) + (if (match (caar overflow)) + (cdar overflow) + (search-overflow (cdr overflow)))))) + (match + (lambda (tags*) + (let loop ((w1 tags*) (w2 tags)) + (and (eq? (system-pair-car w1) (system-pair-car w2)) + (or (null? (system-pair-cdr w1)) + (loop (system-pair-cdr w1) + (system-pair-cdr w2)))))))) + (search-lines line 0)))))) + +(define (compute-primary-cache-line cache tags) + (let ((index (cache-tag-index cache)) + (mask (cache-mask cache))) + (let loop ((tags tags) (line 0)) + (cond ((null? tags) + line) + ((not (system-pair-car tags)) + #f) + (else + (loop (system-pair-cdr tags) + (fix:and (fix:+ line + (dispatch-tag-ref (system-pair-car tags) + index)) + mask))))))) + +(define (cache-entry-reusable? tags tags*) + ;; True iff TAGS is (1) empty, (2) contains a tag that is invalid, + ;; or (3) has the same tags as TAGS*. + (or (not tags) + (let loop ((tags tags) (tags* tags*)) + (or (null? tags) + (not (system-pair-car tags)) + (and (eq? (system-pair-car tags) (system-pair-car tags*)) + (loop (system-pair-cdr tags) (system-pair-cdr tags*))))))) + +(define (cache-count cache) + (let ((length (cache-length cache))) + (do ((line 0 (fix:+ line 1)) + (count 0 + (if (let ((tags (cache-line-tags cache line))) + (and tags + (let loop ((tags tags)) + (or (null? tags) + (and (system-pair-car tags) + (loop (system-pair-cdr tags))))))) + (fix:+ count 1) + count))) + ((fix:= line length) count)))) + +(declare (integrate-operator probe-cache-1)) +(define (probe-cache-1 cache w1) + (let ((line + (fix:and (dispatch-tag-ref w1 (cache-tag-index cache)) + (cache-mask cache))) + (match + (lambda (tags) + (declare (integrate tags)) + (eq? w1 (system-pair-car tags))))) + (declare (integrate line)) + (declare (integrate-operator match)) + (if (match (cache-line-tags cache line)) + (cache-line-value cache line) + (let ((limit (cache-limit cache))) + (let search-lines ((line (cache-next-line cache line)) (i 0)) + (cond ((fix:= i limit) + (let search-overflow ((entries (cache-overflow cache))) + (and (not (null? entries)) + (if (match (caar entries)) + (cdar entries) + (search-overflow (cdr entries)))))) + ((and (cache-line-tags cache line) + (match (cache-line-tags cache line))) + (cache-line-value cache line)) + (else + (search-lines (cache-next-line cache line) + (fix:+ i 1))))))))) + +(declare (integrate-operator probe-cache-2)) +(define (probe-cache-2 cache w1 w2) + (let ((line + (fix:and (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache)) + (dispatch-tag-ref w2 (cache-tag-index cache))) + (cache-mask cache))) + (match + (lambda (tags) + (declare (integrate tags)) + (and (eq? w1 (system-pair-car tags)) + (eq? w2 (system-pair-car (system-pair-cdr tags))))))) + (declare (integrate line)) + (declare (integrate-operator match)) + (if (and (cache-line-tags cache line) + (match (cache-line-tags cache line))) + (cache-line-value cache line) + (let ((limit (cache-limit cache))) + (let search-lines ((line (cache-next-line cache line)) (i 0)) + (cond ((fix:= i limit) + (let search-overflow ((entries (cache-overflow cache))) + (and (not (null? entries)) + (if (match (caar entries)) + (cdar entries) + (search-overflow (cdr entries)))))) + ((and (cache-line-tags cache line) + (match (cache-line-tags cache line))) + (cache-line-value cache line)) + (else + (search-lines (cache-next-line cache line) + (fix:+ i 1))))))))) + +(declare (integrate-operator probe-cache-3)) +(define (probe-cache-3 cache w1 w2 w3) + (let ((line + (fix:and + (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache)) + (fix:+ (dispatch-tag-ref w2 (cache-tag-index cache)) + (dispatch-tag-ref w3 (cache-tag-index cache)))) + (cache-mask cache))) + (match + (lambda (tags) + (declare (integrate tags)) + (and (eq? w1 (system-pair-car tags)) + (eq? w2 (system-pair-car (system-pair-cdr tags))) + (eq? w3 (system-pair-car + (system-pair-cdr (system-pair-cdr tags)))))))) + (declare (integrate line)) + (declare (integrate-operator match)) + (if (match (cache-line-tags cache line)) + (cache-line-value cache line) + (let ((limit (cache-limit cache))) + (let search-lines ((line (cache-next-line cache line)) (i 0)) + (cond ((fix:= i limit) + (let search-overflow ((entries (cache-overflow cache))) + (and (not (null? entries)) + (if (match (caar entries)) + (cdar entries) + (search-overflow (cdr entries)))))) + ((and (cache-line-tags cache line) + (match (cache-line-tags cache line))) + (cache-line-value cache line)) + (else + (search-lines (cache-next-line cache line) + (fix:+ i 1))))))))) + +(declare (integrate-operator probe-cache-4)) +(define (probe-cache-4 cache w1 w2 w3 w4) + (let ((line + (fix:and + (fix:+ (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache)) + (dispatch-tag-ref w2 (cache-tag-index cache))) + (fix:+ (dispatch-tag-ref w3 (cache-tag-index cache)) + (dispatch-tag-ref w4 (cache-tag-index cache)))) + (cache-mask cache))) + (match + (lambda (tags) + (declare (integrate tags)) + (and (eq? w1 (system-pair-car tags)) + (eq? w2 (system-pair-car (system-pair-cdr tags))) + (eq? w3 (system-pair-car + (system-pair-cdr (system-pair-cdr tags)))) + (eq? w4 (system-pair-car + (system-pair-cdr + (system-pair-cdr (system-pair-cdr tags))))))))) + (declare (integrate line)) + (declare (integrate-operator match)) + (if (match (cache-line-tags cache line)) + (cache-line-value cache line) + (let ((limit (cache-limit cache))) + (let search-lines ((line (cache-next-line cache line)) (i 0)) + (cond ((fix:= i limit) + (let search-overflow ((entries (cache-overflow cache))) + (and (not (null? entries)) + (if (match (caar entries)) + (cdar entries) + (search-overflow (cdr entries)))))) + ((and (cache-line-tags cache line) + (match (cache-line-tags cache line))) + (cache-line-value cache line)) + (else + (search-lines (cache-next-line cache line) + (fix:+ i 1))))))))) + +(define (fill-cache cache tags value) + ;; TAGS must be converted to a weak list since it will be stored in + ;; the cache, and we don't want the cache to prevent the tags from + ;; being GCed. + (let ((tags (list->weak-list tags))) + (or (fill-cache-if-possible cache tags value) + (and (< (cache-count cache) (* (cache-length cache) .8)) + (adjust-cache cache tags value)) + (expand-cache cache tags value)))) + +(define (fill-cache-if-possible cache tags value) + (let ((primary (compute-primary-cache-line cache tags))) + (if primary + (let ((free (find-free-cache-line cache primary tags))) + (and free + (begin + (set-cache-line-tags! cache free tags) + (set-cache-line-value! cache free value) + cache))) + ;; TAGS contains an invalid tag. Do nothing and return CACHE + ;; because the fill is no longer needed. While other logic + ;; tries to eliminate this case, it can still happen when one + ;; of the tags is GCed during complex cache operations. + cache))) + +(define (adjust-cache cache tags value) + ;; Try to rehash the cache. If that fails, try rehashing with + ;; different tag indexes. Fail only when all of the tag indexes + ;; have been tried and none has worked. + (let ((length (cache-length cache))) + (let ((new-cache + (make-cache (cache-tag-index cache) + (cache-n-tags cache) + length))) + (letrec + ((fill-lines + (lambda (line) + (cond ((fix:= line length) + (fill-overflow (cache-overflow cache))) + ((try-entry (cache-line-tags cache line) + (cache-line-value cache line)) + (fill-lines (fix:+ line 1))) + (else + (try-next-tag-index))))) + (fill-overflow + (lambda (entries) + (cond ((null? entries) + (or (fill-cache-if-possible new-cache tags value) + (try-next-tag-index))) + ((try-entry (caar entries) (cdar entries)) + (fill-overflow (cdr entries))) + (else + (try-next-tag-index))))) + (try-entry + (lambda (tags* value) + (or (cache-entry-reusable? tags* tags) + (fill-cache-if-possible new-cache tags* value)))) + (try-next-tag-index + (lambda () + (let ((index + (next-dispatch-tag-index (cache-tag-index new-cache)))) + (and index + (begin + (set-cache-tag-index! new-cache index) + (fill-lines 0))))))) + (fill-lines 0))))) + +(define (expand-cache cache tags value) + ;; Create a new cache that is twice the length of CACHE, rehash the + ;; contents of CACHE into the new cache, and make the new entry. + ;; Permits overflows to occur in the new cache. + (let ((length (cache-length cache))) + (letrec + ((fill-lines + (lambda (new-cache line) + (if (fix:= line length) + (fill-overflow new-cache (cache-overflow cache)) + (fill-lines (maybe-do-fill new-cache + (cache-line-tags cache line) + (cache-line-value cache line)) + (fix:+ line 1))))) + (fill-overflow + (lambda (new-cache overflow) + (if (null? overflow) + (do-fill new-cache tags value) + (fill-overflow (maybe-do-fill new-cache + (caar overflow) + (cdar overflow)) + (cdr overflow))))) + (maybe-do-fill + (lambda (cache tags* value) + (if (cache-entry-reusable? tags* tags) + cache + (do-fill cache tags* value)))) + (do-fill + (lambda (cache tags value) + (let ((primary (compute-primary-cache-line cache tags))) + (if primary + (let ((free (find-free-cache-line cache primary tags))) + (if free + (begin + (set-cache-line-tags! cache free tags) + (set-cache-line-value! cache free value) + cache) + (or (adjust-cache cache tags value) + (begin + (set-cache-overflow! + cache + (cons (cons (cache-line-tags cache primary) + (cache-line-value cache primary)) + (cache-overflow cache))) + (set-cache-line-tags! cache primary tags) + (set-cache-line-value! cache primary value) + cache)))) + cache))))) + (fill-lines (make-cache (cache-tag-index cache) + (cache-n-tags cache) + (fix:+ length length)) + 0)))) + +(define (find-free-cache-line cache primary tags) + ;; This procedure searches CACHE for a free line to hold an entry + ;; with the given PRIMARY cache number and TAGS. Since the entry + ;; can only be stored within (CACHE-LIMIT CACHE) lines of PRIMARY, + ;; we either have to find a free line within that limit, or we have + ;; to find a line with a larger primary which can be displaced to + ;; another free line within *its* limit. + (if (cache-entry-reusable? (cache-line-tags cache primary) tags) + primary + (let ((limit (cache-limit cache))) + ;; Find a line for an entry whose primary cache number is P. + ;; LINES is the sequence of entries that is waiting to be + ;; displaced into the line if we find it. + (let pri-loop + ((line (cache-next-line cache primary)) + (p primary) + (tags tags) + (lines '())) + (let sec-loop + ((line line) + (nsep (cache-line-separation cache p line))) + (cond ((fix:= line primary) + ;; We've scanned through the entire cache without + ;; finding a usable line. + #f) + ((let ((tags* (cache-line-tags cache line))) + (and (not (cache-entry-reusable? tags* tags)) + (compute-primary-cache-line cache tags*))) + => + (lambda (lp) + (let ((osep (cache-line-separation cache lp line))) + (cond ((fix:>= osep limit) + ;; This line contains an entry that is + ;; displaced to the limit. [**** For + ;; some reason I don't understand, this + ;; terminates the search.] + #f) + ((or (fix:> nsep osep) + (and (fix:= nsep osep) + (= 0 (random 2)))) + ;; The entry we're trying to place is + ;; further from its primary than the + ;; entry currently stored in this line. + ;; So now let's look for somewhere to + ;; displace the entry in this line. + (pri-loop (cache-next-line cache line) + lp + (cache-line-tags cache line) + (cons line lines))) + (else + (sec-loop (cache-next-line cache line) + (fix:+ nsep 1))))))) + (else + ;; Found a free line. First perform all of the + ;; entry displacements, then return the subsequent + ;; free line. + (without-interrupts + (lambda () + (let loop ((free-line line) (lines lines)) + (if (null? lines) + (begin + (set-cache-line-tags! cache free-line #f) + (set-cache-line-value! cache free-line #f) + free-line) + (let ((line (car lines))) + (set-cache-line-tags! + cache + free-line + (cache-line-tags cache line)) + (set-cache-line-value! + cache + free-line + (cache-line-value cache line)) + (loop line (cdr lines)))))))))))))) + +(define (purge-cache-entries cache predicate) + (if (there-exists-a-cache-entry? cache predicate) + ;; Must rebuild cache since deletions are near-impossible. + (let loop + ((cache (new-cache (cache-n-tags cache))) + (alist (cache->alist cache))) + (if (null? alist) + cache + (loop (if (predicate (caar alist)) + cache + (fill-cache cache (caar alist) (cdar alist))) + (cdr alist)))) + cache)) + +(define (there-exists-a-cache-entry? cache predicate) + (let ((length (cache-length cache))) + (let loop ((line 0)) + (and (not (fix:= line length)) + (let ((tags (cache-line-tags cache line))) + (if (or (not tags) + (not (system-pair-car tags))) + (loop (fix:+ line 1)) + (or (predicate (weak-list->list tags)) + (loop (fix:+ line 1))))))))) + +(define (cache->alist cache) + (let ((length (cache-length cache))) + (do ((line 0 (fix:+ line 1)) + (alist '() + (let ((tags (cache-line-tags cache line))) + (if (or (not tags) + (not (system-pair-car tags))) + alist + (cons (cons (weak-list->list tags) + (cache-line-value cache line)) + alist))))) + ((fix:= line length) alist)))) \ No newline at end of file diff --git a/v7/src/runtime/geneqht.scm b/v7/src/runtime/geneqht.scm new file mode 100644 index 000000000..1af749b8f --- /dev/null +++ b/v7/src/runtime/geneqht.scm @@ -0,0 +1,258 @@ +#| -*-Scheme-*- + +$Id: geneqht.scm,v 1.1 1996/04/23 20:37:27 cph Exp $ + +Copyright (c) 1990-96 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; EQ?-Hash Tables for Generic Procedures + +(declare (usual-integrations)) + +(define (make-eqht) + (let ((table (%make-eqht))) + (reset-table! table) + (record-address-hash-table! table) + table)) + +(define (eqht/get table key default) + (let ((entries + (vector-ref (table-buckets table) (compute-key-hash table key)))) + (let loop ((entries entries)) + (cond ((null? entries) + default) + ((eq? (system-pair-car (car entries)) key) + (system-pair-cdr (car entries))) + (else + (loop (cdr entries))))))) + +(define (eqht/put! table key datum) + (let ((buckets (table-buckets table)) + (hash (compute-key-hash table key))) + (let loop ((entries (vector-ref buckets hash))) + (cond ((null? entries) + (without-interrupts + (lambda () + (vector-set! buckets + hash + (cons (weak-cons key datum) + (vector-ref buckets hash))) + (if (> (let ((count (fix:+ (table-count table) 1))) + (set-table-count! table count) + count) + (table-grow-size table)) + (grow-table! table))))) + ((eq? (system-pair-car (car entries)) key) + (system-pair-set-cdr! (car entries) datum)) + (else + (loop (cdr entries))))))) + +(define (eqht/for-each table procedure) + (for-each-vector-element (table-buckets table) + (lambda (entries) + (for-each (lambda (entry) + (if (system-pair-car entry) + (procedure (system-pair-car entry) + (system-pair-cdr entry)))) + entries)))) + +;;;; Address Hashing + +(define (compute-key-hash table key) + (let loop () + (let ((hash (eq-hash-mod key (vector-length (table-buckets table))))) + (if (not (table-needs-rehash? table)) + hash + (begin + (without-interrupts (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) + (set! address-hash-tables (weak-cons table address-hash-tables)) + unspecific) + +(define (mark-address-hash-tables!) + (let loop ((previous #f) (tables address-hash-tables)) + (cond ((null? tables) + unspecific) + ((system-pair-car tables) + (set-table-needs-rehash?! (system-pair-car tables) #t) + (loop tables (system-pair-cdr tables))) + (else + (if previous + (system-pair-set-cdr! previous (system-pair-cdr tables)) + (set! address-hash-tables (system-pair-cdr tables))) + (loop previous (system-pair-cdr tables)))))) + +(define address-hash-tables) + +(define (initialize-address-hashing!) + (set! address-hash-tables '()) + (add-primitive-gc-daemon! mark-address-hash-tables!)) + +;;;; Resizing + +(define (grow-table! table) + (let loop ((size (table-grow-size table))) + (if (> (table-count table) size) + (loop (let ((size* (round->exact (* size 2.)))) + (if (> size* size) + size* + (+ size 1)))) + (new-size! table size)))) + +(define (shrink-table! table) + (let loop ((size (table-grow-size table))) + (cond ((<= size minimum-size) + (new-size! table minimum-size)) + ((< (table-count table) (compute-shrink-size size)) + (loop (decrement-size size))) + (else + (new-size! table size))))) + +(define (new-size! table size) + (set-table-grow-size! table size) + (let ((old-buckets (table-buckets table))) + (reset-table! table) + (rehash-table-from-old-buckets! table old-buckets))) + +(define (reset-table! table) + (set-table-shrink-size! table (compute-shrink-size (table-grow-size table))) + (let ((primes + (let ((size (round->exact (table-grow-size table)))) + (let loop + ((primes + (if (< size (stream-car (table-primes table))) + prime-numbers-stream + (table-primes table)))) + (if (<= size (stream-car primes)) + primes + (loop (stream-cdr primes))))))) + (set-table-primes! table primes) + (set-table-buckets! table (make-vector (stream-car primes) '())))) + +(define (compute-shrink-size size) + (if (<= size minimum-size) + 0 + (max 0 (decrement-size (decrement-size size))))) + +(define (decrement-size size) + (let ((size* (round->exact (/ size 2.)))) + (if (< size* size) + size* + (- size 1)))) + +;;;; Rehashing + +(define (rehash-table-from-old-buckets! table buckets) + (let ((n-buckets (vector-length buckets))) + (set-table-needs-rehash?! table #f) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n-buckets)) + (let ((entries (vector-ref buckets i))) + (if (not (null? entries)) + (rehash-table-entries! table entries))))) + (maybe-shrink-table! table)) + +(define (rehash-table-entries! table entries) + (let ((buckets (table-buckets table))) + (let ((n-buckets (vector-length buckets))) + (let loop ((entries entries)) + (if (not (null? entries)) + (let ((rest (cdr entries))) + (if (system-pair-car (car entries)) + (let ((hash + (eq-hash-mod (system-pair-car (car entries)) + n-buckets))) + (set-cdr! entries (vector-ref buckets hash)) + (vector-set! buckets hash entries)) + (set-table-count! table (fix:- (table-count table) 1))) + (loop rest))))))) + +(define (maybe-shrink-table! table) + ;; Since the rehashing also deletes invalid entries, the count + ;; might have been reduced. So check to see if it's necessary to + ;; shrink the table even further. + (if (< (table-count table) (table-shrink-size table)) + (shrink-table! table))) + +(define (rehash-table! table) + (let ((entries (extract-table-entries! table))) + (set-table-needs-rehash?! table #f) + (rehash-table-entries! table entries)) + (maybe-shrink-table! table)) + +(define (extract-table-entries! table) + (let ((buckets (table-buckets table))) + (let ((n-buckets (vector-length buckets))) + (let ((entries '())) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n-buckets)) + (let ((bucket (vector-ref buckets i))) + (if (not (null? bucket)) + (begin + (let loop ((bucket bucket)) + (if (null? (cdr bucket)) + (set-cdr! bucket entries) + (loop (cdr bucket)))) + (set! entries bucket) + (vector-set! buckets i '()))))) + entries)))) + +;;;; Miscellaneous + +(define-structure (eqht (constructor %make-eqht ()) (conc-name table-)) + (count 0) + (grow-size minimum-size) + (shrink-size 0) + buckets + (primes prime-numbers-stream) + (needs-rehash? #f)) + +(define-integrable minimum-size 4) + +(define-integrable (without-interrupts thunk) + (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (thunk) + (set-interrupt-enables! interrupt-mask) + unspecific)) + +(define-integrable (weak-cons car cdr) + (system-pair-cons (ucode-type weak-cons) car cdr)) \ No newline at end of file diff --git a/v7/src/runtime/generic.scm b/v7/src/runtime/generic.scm new file mode 100644 index 000000000..26b23a81b --- /dev/null +++ b/v7/src/runtime/generic.scm @@ -0,0 +1,432 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: generic.scm,v 1.1 1996/04/23 20:37:35 cph Exp $ +;;; +;;; Copyright (c) 1995-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Generic Procedures + +(declare (usual-integrations) + (integrate-external "gentag" "gencache")) + +;;;; Generic Procedures + +(define (make-generic-procedure arity #!optional name tag generator) + (let ((name (if (default-object? name) #f name)) + (tag (if (default-object? tag) #f tag)) + (generator (if (default-object? generator) #f generator))) + (if (and name (not (symbol? name))) + (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE)) + (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE)) + (if (not (or (and (exact-integer? arity) + (> arity 0)) + (and (pair? arity) + (exact-integer? (car arity)) + (> (car arity) 0) + (or (not (cdr arity)) + (and (exact-integer? (cdr arity)) + (>= (cdr arity) (car arity))))))) + (error:wrong-type-argument arity "arity" + 'MAKE-GENERIC-PROCEDURE)) + (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE) + (let ((record + (make-generic-record (or tag standard-generic-procedure-tag) + (if (and (pair? arity) + (eqv? (car arity) (cdr arity))) + (car arity) + arity) + generator + name))) + (let ((generic (compute-apply-generic record))) + (set-generic-record/procedure! record generic) + (eqht/put! generic-procedure-records generic record) + generic)))) + +(define-structure (generic-record + (conc-name generic-record/) + (constructor make-generic-record + (tag arity generator name))) + (tag #f read-only #t) + (arity #f read-only #t) + (generator #f) + (name #f read-only #t) + (cache (new-cache (if (pair? arity) (car arity) arity))) + procedure) + +(define (generic-record/min-arity record) + (arity-min (generic-record/arity record))) + +(define (generic-record/max-arity record) + (arity-max (generic-record/arity record))) + +(define (arity-min arity) + (if (pair? arity) (car arity) arity)) + +(define (arity-max arity) + (if (pair? arity) (cdr arity) arity)) + +(define (generic-procedure? object) + (if (eqht/get generic-procedure-records object #f) #t #f)) + +(define (generic-procedure-arity generic) + (generic-record/arity + (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY))) + +(define (generic-procedure-name generic) + (generic-record/name + (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-NAME))) + +(define (generic-procedure-generator generic) + (generic-record/generator + (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-GENERATOR))) + +(define (set-generic-procedure-generator! generic generator) + (let ((record + (guarantee-generic-procedure generic + 'SET-GENERIC-PROCEDURE-GENERATOR!))) + (guarantee-generator generator 'SET-GENERIC-PROCEDURE-GENERATOR!) + (without-interrupts + (lambda () + (set-generic-record/generator! record generator) + (%reset-generic-procedure-cache! record))))) + +(define (purge-generic-procedure-cache generic #!optional filter) + (let ((operator + (if (or (default-object? filter) + (eq? 'ALL-ENTRIES filter)) + (lambda (generic record) + generic + (%reset-generic-procedure-cache! record)) + (lambda (generic record) + (%purge-generic-procedure-cache! generic record filter))))) + (if (eq? 'ALL-PROCEDURES generic) + (eqht/for-each generic-procedure-records operator) + (operator + generic + (guarantee-generic-procedure generic + 'PURGE-GENERIC-PROCEDURE-CACHE))))) + +(define (%reset-generic-procedure-cache! record) + (set-generic-record/cache! record + (new-cache (generic-record/min-arity record)))) + +(define (%purge-generic-procedure-cache! generic record filter) + ;; This might have interrupts locked for a long time, and thus is an + ;; argument for using something like a semaphore to control access. + (without-interrupts + (lambda () + (set-generic-record/cache! + record + (purge-cache-entries (generic-record/cache record) + (lambda (tags) (filter generic tags))))))) + +(define (guarantee-generic-procedure generic caller) + (or (eqht/get generic-procedure-records generic #f) + (error:wrong-type-argument generic "generic procedure" caller))) + +(define (guarantee-generator generator caller) + (if (not (or (not generator) + (and (procedure? generator) + (procedure-arity-valid? generator 2)))) + (error:wrong-type-argument generator + "generic procedure generator" + caller))) + +;;;; Generic Procedure Application + +(define (compute-apply-generic record) + (let ((arity (generic-record/arity record))) + (cond ((pair? arity) (apply-generic record)) + ((= 1 arity) (apply-generic-1 record)) + ((= 2 arity) (apply-generic-2 record)) + ((= 3 arity) (apply-generic-3 record)) + ((= 4 arity) (apply-generic-4 record)) + (else (apply-generic record))))) + +(define (apply-generic record) + (let ((min-arity (generic-record/min-arity record)) + (max-arity (generic-record/max-arity record))) + (let ((extra (and max-arity (- max-arity min-arity)))) + (letrec + ((generic + (lambda args + (let loop ((args* args) (n min-arity) (tags '())) + (if (fix:= n 0) + (begin + (if (and extra + (let loop ((args* args*) (n extra)) + (and (not (null? args*)) + (or (fix:= n 0) + (loop (cdr args*) + (fix:- n 1)))))) + (wna args)) + (let ((procedure + (probe-cache (generic-record/cache record) tags))) + (if procedure + (apply procedure args) + (compute-method-and-store record args)))) + (begin + (if (null? args*) + (wna args)) + (loop (cdr args*) + (fix:- n 1) + (cons (dispatch-tag (car args*)) tags))))))) + (wna + (lambda (args) + (error:wrong-number-of-arguments generic + (generic-record/arity record) + args)))) + generic)))) + +(define (generic-procedure-applicable? procedure arguments) + (let ((record + (guarantee-generic-procedure procedure + 'GENERIC-PROCEDURE-APPLICABLE?)) + (tags (map dispatch-tag arguments))) + (let ((generator (generic-record/generator record)) + (arity (generic-record/arity record)) + (n-args (length tags))) + (and generator + (if (pair? arity) + (let ((min-arity (arity-min arity)) + (max-arity (arity-max arity))) + (if (fix:= n-args min-arity) + (generator procedure tags) + (and (fix:> n-args min-arity) + (or (not max-arity) + (fix:<= n-args max-arity)) + (generator procedure (list-head tags min-arity))))) + (and (fix:= arity n-args) + (generator procedure tags))))))) + +(define (apply-generic-1 record) + (lambda (a1) + (declare (integrate-operator dispatch-tag)) + (let ((procedure + (probe-cache-1 (generic-record/cache record) + (dispatch-tag a1)))) + (if procedure + (procedure a1) + (compute-method-and-store record (list a1)))))) + +(define (apply-generic-2 record) + (lambda (a1 a2) + (declare (integrate-operator dispatch-tag)) + (let ((procedure + (probe-cache-2 (generic-record/cache record) + (dispatch-tag a1) + (dispatch-tag a2)))) + (if procedure + (procedure a1 a2) + (compute-method-and-store record (list a1 a2)))))) + +(define (apply-generic-3 record) + (lambda (a1 a2 a3) + (declare (integrate-operator dispatch-tag)) + (let ((procedure + (probe-cache-3 (generic-record/cache record) + (dispatch-tag a1) + (dispatch-tag a2) + (dispatch-tag a3)))) + (if procedure + (procedure a1 a2 a3) + (compute-method-and-store record (list a1 a2 a3)))))) + +(define (apply-generic-4 record) + (lambda (a1 a2 a3 a4) + (declare (integrate-operator dispatch-tag)) + (let ((procedure + (probe-cache-4 (generic-record/cache record) + (dispatch-tag a1) + (dispatch-tag a2) + (dispatch-tag a3) + (dispatch-tag a4)))) + (if procedure + (procedure a1 a2 a3 a4) + (compute-method-and-store record (list a1 a2 a3 a4)))))) + +(define (compute-method-and-store record args) + (let ((tags (map dispatch-tag args))) + (let ((procedure + (let ((generator (generic-record/generator record)) + (generic (generic-record/procedure record))) + (or (and generator (generator generic tags)) + (error:no-applicable-methods generic args))))) + (without-interrupts + (lambda () + (set-generic-record/cache! + record + (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) + (or (vector-ref microcode-type-tag-table (object-type object)) + ((vector-ref microcode-type-method-table (object-type object)) + object)))) + +(define (make-built-in-tag name) + (let ((entry (assq name built-in-tag-table))) + (if entry + (cdr entry) + (let ((tag (make-dispatch-tag name))) + (set! built-in-tag-table (cons (cons name tag) built-in-tag-table)) + tag)))) + +(define (built-in-dispatch-tags) + (map cdr built-in-tag-table)) + +(define (built-in-dispatch-tag name) + (let ((entry (assq name built-in-tag-table))) + (and entry + (cdr entry)))) + +(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 built-in-tag-table) +(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)) + + ;; Initialize the built-in tag tables. + (set! built-in-tag-table '()) + (set! microcode-type-tag-table + (make-initialized-vector (microcode-type/code-limit) + (lambda (code) + (make-built-in-tag + (or (microcode-type/code->name code) '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 (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))) + (if (> microcode-id/version 11) + (assign-type 'CONSTANT + (lambda (default-tag) + (lambda (object) + (if (or (eq? #f object) (eq? #t object)) + boolean-tag + default-tag)))) + (begin + (assign-type 'FALSE + (lambda (default-tag) + (lambda (object) + (if (eq? #f object) + boolean-tag + default-tag)))) + (assign-type 'CONSTANT + (lambda (default-tag) + (lambda (object) + (if (eq? #t object) + boolean-tag + default-tag))))))) + (assign-type 'FLONUM + (let ((flonum-vector-tag + (make-built-in-tag 'FLONUM-VECTOR))) + (lambda (default-tag) + (lambda (object) + (if (fix:= 2 (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 diff --git a/v7/src/runtime/genmult.scm b/v7/src/runtime/genmult.scm new file mode 100644 index 000000000..598b5997f --- /dev/null +++ b/v7/src/runtime/genmult.scm @@ -0,0 +1,189 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: genmult.scm,v 1.1 1996/04/23 20:37:42 cph Exp $ +;;; +;;; Copyright (c) 1995-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Multiplexed Generic Procedures + +;;; This code assumes that a non-multiplexed generic procedure +;;; generator is equivalent to the same generator stored in a +;;; multiplexer. Multiplexers assume that each of their generators is +;;; applicable to a particular set of objects, and that the set does +;;; not intersect any of the sets handled by other generators stored +;;; in the same multiplexer. Combining these two assumptions means +;;; that a non-multiplexed generator must follow the convention for +;;; multiplexed generators, even though there is no reason to do so in +;;; the absence of multiplexers. + +;;; This convention is encouraged by hiding the low-level procedures +;;; that allow direct access to a generic procedure's generator, and +;;; forcing the programmer to go through the multiplexing interface. +;;; That way, multiplexing appears to be an integral part of the +;;; generic-procedure interface. + +(declare (usual-integrations)) + +(define (generic-procedure-generator-list generic) + (let ((m (generic-procedure-generator generic))) + (if m + (if (multiplexer? m) + (list-copy (multiplexer-list m)) + (list m)) + '()))) + +(define (add-generic-procedure-generator generic generator) + (let ((m (generic-procedure-generator generic))) + (if (multiplexer? m) + (begin + (purge-generic-procedure-cache generic) + (add-generator m generator)) + (add-generator (install-multiplexer generic) generator)))) + +(define (remove-generic-procedure-generator generic generator) + (let ((m (generic-procedure-generator generic))) + (if (multiplexer? m) + (begin + (purge-generic-procedure-cache generic) + (set-multiplexer-list! m (delq! generator (multiplexer-list m))) + (maybe-deinstall-multiplexer generic)) + (if (eq? generator m) + (set-generic-procedure-generator! generic #f))))) + +(define (remove-generic-procedure-generators generic tags) + (for-each (lambda (generator) + (if (generator generic tags) + (remove-generic-procedure-generator generic generator))) + (generic-procedure-generator-list generic))) + +(define (generic-procedure-default-generator generic) + (let ((m (generic-procedure-generator generic))) + (and (multiplexer? m) + (multiplexer-default m)))) + +(define (set-generic-procedure-default-generator! generic generator) + (let ((m (generic-procedure-generator generic))) + (cond ((multiplexer? m) + (purge-generic-procedure-cache generic) + (set-multiplexer-default! m generator) + (maybe-deinstall-multiplexer generic)) + (generator + (set-multiplexer-default! (install-multiplexer generic) + generator))))) + +(define (install-multiplexer generic) + (let ((m (make-multiplexer))) + (let ((g (generic-procedure-generator generic))) + (if g + (add-generator m g))) + (set-generic-procedure-generator! generic m) + m)) + +(define (add-generator m generator) + (set-multiplexer-list! m (cons generator (multiplexer-list m)))) + +(define (maybe-deinstall-multiplexer generic) + (let* ((m (generic-procedure-generator generic)) + (generators (multiplexer-list m))) + (cond ((and (null? generators) + (not (multiplexer-default m))) + (set-generic-procedure-generator! generic #f)) + ((and (null? (cdr generators)) + (not (multiplexer-default m))) + (set-generic-procedure-generator! generic (car generators)))))) + +(define (make-multiplexer) + (make-entity (lambda (multiplexer generic tags) + (multiplexer-dispatch multiplexer generic tags)) + (make-multiplexer-record '() #f))) + +(define (multiplexer? object) + (and (entity? object) + (multiplexer-record? (entity-extra object)))) + +(define (multiplexer-list multiplexer) + (multiplexer-record/list (entity-extra multiplexer))) + +(define (set-multiplexer-list! multiplexer list) + (set-multiplexer-record/list! (entity-extra multiplexer) list)) + +(define (multiplexer-default multiplexer) + (multiplexer-record/default (entity-extra multiplexer))) + +(define (set-multiplexer-default! multiplexer default) + (set-multiplexer-record/default! (entity-extra multiplexer) default)) + +(define-structure (multiplexer-record (conc-name multiplexer-record/)) + list + default) + +(define (multiplexer-dispatch multiplexer generic tags) + (let loop ((generators (multiplexer-list multiplexer))) + (if (null? generators) + (let ((default (multiplexer-default multiplexer))) + (and default + (default generic tags))) + (let ((procedure ((car generators) generic tags))) + (cond ((not procedure) + (loop (cdr generators))) + ((there-exists? (cdr generators) + (lambda (generator) + (generator generic tags))) + (lambda args + (error:extra-applicable-methods generic args))) + (else procedure)))))) + +(define multiplexer-tag) +(define del-rassq) +(define condition-type:extra-applicable-methods) +(define error:extra-applicable-methods) + +(define (initialize-multiplexer!) + (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER)) + (set! del-rassq (delete-association-procedure list-deletor eq? cdr)) + 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 diff --git a/v7/src/runtime/gentag.scm b/v7/src/runtime/gentag.scm new file mode 100644 index 000000000..4879828fd --- /dev/null +++ b/v7/src/runtime/gentag.scm @@ -0,0 +1,107 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: gentag.scm,v 1.1 1996/04/23 20:37:51 cph Exp $ +;;; +;;; Copyright (c) 1993-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Tags for Generic Procedure Dispatch + +;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis +;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and +;;; Functional Programming. Parts of this code are based on the +;;; September 16, 1992 PCL implementation. + +(declare (usual-integrations)) + +(define (make-dispatch-tag contents) + (let ((tag + (object-new-type + (ucode-type record) + ((ucode-primitive vector-cons) dispatch-tag-index-end #f)))) + (%record-set! tag 0 dispatch-tag-marker) + (%record-set! tag 1 contents) + (do ((i dispatch-tag-index-start (fix:+ i 1))) + ((fix:= i dispatch-tag-index-end)) + (%record-set! tag i (get-dispatch-tag-cache-number))) + tag)) + +(define-integrable (dispatch-tag? object) + (and (%record? object) + (eq? dispatch-tag-marker (%record-ref object 0)))) + +(define-integrable dispatch-tag-marker + ((ucode-primitive string->symbol) "#[dispatch-tag]")) + +(define-integrable dispatch-tag-index-start 2) +(define-integrable dispatch-tag-index-end 10) +(define-integrable dispatch-tag-ref %record-ref) +(define-integrable dispatch-tag-set! %record-set!) + +(define (dispatch-tag-contents tag) + (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS) + (%record-ref tag 1)) + +(define (set-dispatch-tag-contents! tag contents) + (guarantee-dispatch-tag tag 'SET-DISPATCH-TAG-CONTENTS!) + (%record-set! tag 1 contents)) + +(define-integrable (guarantee-dispatch-tag tag caller) + (if (not (dispatch-tag? tag)) + (error:wrong-type-argument tag "dispatch tag" caller))) + +(declare (integrate-operator next-dispatch-tag-index)) +(define (next-dispatch-tag-index index) + (and (fix:< (fix:+ index 1) dispatch-tag-index-end) + (fix:+ index 1))) + +(define-integrable dispatch-tag-cache-number-adds-ok + ;; This constant controls the number of non-zero bits tag cache + ;; numbers will have. + ;; + ;; The value of this constant is the number of tag cache numbers + ;; that can be added and still be certain the result will be a + ;; fixnum. This is implicitly used by all the code that computes + ;; 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 diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm new file mode 100644 index 000000000..c9ae17f46 --- /dev/null +++ b/v7/src/runtime/recslot.scm @@ -0,0 +1,106 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: recslot.scm,v 1.1 1996/04/23 20:37:58 cph Exp $ +;;; +;;; Copyright (c) 1995-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; 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-macro (generate-index-cases index limit expand-case) + `(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)) + (lambda (record) (%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)) + (lambda (record) + (not (eq? record-slot-uninitialized (%record-ref record 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))))))) \ No newline at end of file diff --git a/v7/src/runtime/tvector.scm b/v7/src/runtime/tvector.scm new file mode 100644 index 000000000..c81e6e818 --- /dev/null +++ b/v7/src/runtime/tvector.scm @@ -0,0 +1,106 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: tvector.scm,v 1.1 1996/04/23 20:38:03 cph Exp $ +;;; +;;; Copyright (c) 1995-96 Massachusetts Institute of Technology +;;; +;;; This material was developed by the Scheme project at the +;;; Massachusetts Institute of Technology, Department of Electrical +;;; Engineering and Computer Science. Permission to copy this +;;; software, to redistribute it, and to use it for any purpose is +;;; granted, subject to the following restrictions and understandings. +;;; +;;; 1. Any copy made of this software must include this copyright +;;; notice in full. +;;; +;;; 2. Users of this software agree to make their best efforts (a) to +;;; return to the MIT Scheme project any improvements or extensions +;;; that they make, so that these may be included in future releases; +;;; and (b) to inform MIT of noteworthy uses of this software. +;;; +;;; 3. All materials developed as a consequence of the use of this +;;; software shall duly acknowledge such use, in accordance with the +;;; usual standards of acknowledging credit in academic research. +;;; +;;; 4. MIT has made no warrantee or representation that the operation +;;; of this software will be error-free, and MIT is under no +;;; obligation to provide any services, by way of maintenance, update, +;;; or otherwise. +;;; +;;; 5. In conjunction with products arising from the use of this +;;; material, there shall be no use of the name of the Massachusetts +;;; Institute of Technology nor of any adaptation thereof in any +;;; advertising, promotional, or sales literature without prior +;;; written consent from MIT in each case. + +;;;; Tagged Vectors + +(declare (usual-integrations)) + +;;; These procedures are optimized for safety. Applications that need +;;; speed are assumed to break this abstraction and use "%record" +;;; calls to construct and access tagged vectors. + +(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)) + +(define (tagged-vector tag . elements) + (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR) + (object-new-type (ucode-type record) (apply vector tag elements))) + +(define (tagged-vector? object) + (and (%record? object) + (dispatch-tag? (%record-ref object 0)))) + +(define (tagged-vector-tag vector) + (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG) + (%record-ref vector 0)) + +(define (set-tagged-vector-tag! vector tag) + (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!) + (guarantee-dispatch-tag tag 'SET-TAGGED-VECTOR-TAG!) + (%record-set! vector 0 tag)) + +(define (tagged-vector-length vector) + (guarantee-tagged-vector vector 'TAGGED-VECTOR-LENGTH) + (fix:- (%record-length vector) 1)) + +(define (tagged-vector-element vector index) + (guarantee-tagged-vector-ref vector index 'TAGGED-VECTOR-ELEMENT) + (%record-ref vector (fix:+ index 1))) + +(define (set-tagged-vector-element! vector index value) + (guarantee-tagged-vector-ref vector index 'SET-TAGGED-VECTOR-ELEMENT!) + (%record-set! vector (fix:+ index 1) value)) + +(define (tagged-vector-element-initialized? vector index) + (guarantee-tagged-vector-ref vector index + 'TAGGED-VECTOR-ELEMENT-INITIALIZED?) + (not (eq? (%record-ref vector (fix:+ index 1)) record-slot-uninitialized))) + +(define (guarantee-tagged-vector vector caller) + (if (not (tagged-vector? vector)) + (error:wrong-type-argument vector "tagged vector" caller))) + +(define (guarantee-tagged-vector-ref vector index caller) + (guarantee-tagged-vector vector caller) + (guarantee-index-integer index caller) + (if (not (fix:< index (fix:- (%record-length vector) 1))) + (error:bad-range-argument index caller))) + +(define (guarantee-index-integer index caller) + (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 -- 2.25.1