From: Chris Hanson Date: Thu, 4 Jan 2001 22:07:45 +0000 (+0000) Subject: Implement external-string mechanism for storing text data outside of X-Git-Tag: 20090517-FFI~3022 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5fb76467a89c142ae8fe69c50557aad06500ed9f;p=mit-scheme.git Implement external-string mechanism for storing text data outside of Scheme's heap. --- diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index a5387d6aa..6433e7a52 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: prims.h,v 9.46 1999/01/02 06:11:34 cph Exp $ +$Id: prims.h,v 9.47 2001/01/04 22:07:41 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright (c) 1987-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -101,6 +101,8 @@ extern long EXFUN (arg_ascii_integer, (int)); ? ((char *) (STRING_LOC ((ARG_REF (arg)), 0))) \ : ((error_wrong_type_arg (arg)), ((char *) 0))) +extern PTR EXFUN (arg_extended_string, (unsigned int, unsigned long *)); + #define BOOLEAN_ARG(arg) ((ARG_REF (arg)) != SHARP_F) #define CELL_ARG(arg) \ diff --git a/v7/src/microcode/prosio.c b/v7/src/microcode/prosio.c index 09a96f0f2..e35d199f9 100644 --- a/v7/src/microcode/prosio.c +++ b/v7/src/microcode/prosio.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: prosio.c,v 1.17 1999/01/02 06:11:34 cph Exp $ +$Id: prosio.c,v 1.18 2001/01/04 22:07:42 cph Exp $ Copyright (c) 1987-1999 Massachusetts Institute of Technology @@ -152,15 +152,14 @@ Attempt to fill that substring unless end-of-file is reached.\n\ Return the number of characters actually read from CHANNEL.") { PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); { - SCHEME_OBJECT buffer = (ARG_REF (2)); - long length = (STRING_LENGTH (buffer)); - long end = (arg_index_integer (4, (length + 1))); - long start = (arg_index_integer (3, (end + 1))); + unsigned long length; + char * buffer = (arg_extended_string (2, (&length))); + unsigned long end = (arg_ulong_index_integer (4, (length + 1))); + unsigned long start = (arg_ulong_index_integer (3, (end + 1))); long nread = (OS_channel_read ((arg_channel (1)), - (STRING_LOC (buffer, start)), + (buffer + start), (end - start))); PRIMITIVE_RETURN ((nread < 0) ? SHARP_F : (long_to_integer (nread))); } @@ -171,15 +170,14 @@ DEFINE_PRIMITIVE ("CHANNEL-WRITE", Prim_channel_write, 4, 4, Third and fourth args START and END specify the substring to use.") { PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); { - SCHEME_OBJECT buffer = (ARG_REF (2)); - long length = (STRING_LENGTH (buffer)); - long end = (arg_index_integer (4, (length + 1))); - long start = (arg_index_integer (3, (end + 1))); + unsigned long length; + CONST char * buffer = (arg_extended_string (2, (&length))); + unsigned long end = (arg_ulong_index_integer (4, (length + 1))); + unsigned long start = (arg_ulong_index_integer (3, (end + 1))); long nwritten = (OS_channel_write ((arg_channel (1)), - (STRING_LOC (buffer, start)), + (buffer + start), (end - start))); PRIMITIVE_RETURN ((nwritten < 0) ? SHARP_F : (long_to_integer (nwritten))); } diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c index e309179be..c283d23f1 100644 --- a/v7/src/microcode/string.c +++ b/v7/src/microcode/string.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: string.c,v 9.38 1999/01/02 06:11:34 cph Exp $ +$Id: string.c,v 9.39 2001/01/04 22:07:43 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright (c) 1987-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -23,6 +23,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #include "scheme.h" #include "prims.h" + +#ifndef STDC_HEADERS +# ifdef HAVE_MALLOC_H +# include +# else + extern PTR EXFUN (malloc, (size_t)); + extern PTR EXFUN (realloc, (PTR, size_t)); +# endif +#endif SCHEME_OBJECT DEFUN (allocate_string, (nbytes), fast long nbytes) @@ -160,28 +169,26 @@ DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_vec_8b_set, 3, 3, 0) STRING_SET_BODY (arg_ascii_integer) #define SUBSTRING_MOVE_PREFIX() \ - long start1, end1, start2, end2, length; \ - fast unsigned char *scan1, *scan2, *limit; \ + unsigned char *ptr1, *ptr2; \ + unsigned long len1, len2; \ + unsigned long start1, end1, start2, end2, length; \ + unsigned char *scan1, *scan2, *limit; \ PRIMITIVE_HEADER (5); \ - CHECK_ARG (1, STRING_P); \ - start1 = (arg_nonnegative_integer (2)); \ - end1 = (arg_nonnegative_integer (3)); \ - CHECK_ARG (4, STRING_P); \ - start2 = (arg_nonnegative_integer (5)); \ + ptr1 = (arg_extended_string (1, (&len1))); \ + end1 = (arg_ulong_index_integer (3, (len1 + 1))); \ + start1 = (arg_ulong_index_integer (2, (end1 + 1))); \ + ptr2 = (arg_extended_string (4, (&len2))); \ + start2 = (arg_ulong_index_integer (5, (len2 + 1))); \ length = (end1 - start1); \ end2 = (start2 + length); \ - if (end1 > (STRING_LENGTH (ARG_REF (1)))) \ - error_bad_range_arg (2); \ - if (start1 > end1) \ - error_bad_range_arg (1); \ - if (end2 > (STRING_LENGTH (ARG_REF (4)))) \ - error_bad_range_arg (3) + if (end2 > len2) \ + error_bad_range_arg (5) DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0) { SUBSTRING_MOVE_PREFIX (); - scan1 = (STRING_LOC ((ARG_REF (1)), end1)); - scan2 = (STRING_LOC ((ARG_REF (4)), end2)); + scan1 = (ptr1 + end1); + scan2 = (ptr2 + end2); limit = (scan1 - length); while (scan1 > limit) (*--scan2) = (*--scan1); @@ -191,8 +198,8 @@ DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0) DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_substring_move_left, 5, 5, 0) { SUBSTRING_MOVE_PREFIX (); - scan1 = (STRING_LOC ((ARG_REF (1)), start1)); - scan2 = (STRING_LOC ((ARG_REF (4)), start2)); + scan1 = (ptr1 + start1); + scan2 = (ptr2 + start2); limit = (scan1 + length); while (scan1 < limit) (*scan2++) = (*scan1++); @@ -478,3 +485,300 @@ DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1))); PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length)); } + +/* External strings */ + +/* An external string is just a chunk of memory allocated using malloc + outside of Scheme's address space. It is represented to Scheme as + an integer -- the address of the memory. Each external string is + registered in a hash table when it is allocated so that we can + validate the incoming integers. */ + +typedef struct ht_record_s ht_record_t; +struct ht_record_s +{ + ht_record_t * next; + unsigned long n_bytes; +}; + +#define HT_RECORD_PTR(record) ((PTR) ((record) + 1)) +#define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1)) +#define HT_RECORD_NEXT(record) ((record) -> next) +#define HT_RECORD_N_BYTES(record) ((record) -> n_bytes) + +typedef struct +{ + unsigned long n_records; + unsigned long n_buckets; + ht_record_t ** buckets; +} hash_table_t; + +#define HT_N_RECORDS(table) ((table) -> n_records) +#define HT_N_BUCKETS(table) ((table) -> n_buckets) +#define HT_BUCKET_INDEX(table, key) ((key) % (HT_N_BUCKETS (table))) +#define HT_BUCKETS(table) ((table) -> buckets) +#define HT_BUCKET_REF(table, index) ((HT_BUCKETS (table)) [(index)]) +#define HT_SHRINK_POINT(table) ((((HT_N_BUCKETS (table)) + 1) / 2) - 1) + +static hash_table_t * EXFUN (make_hash_table, (void)); +static void EXFUN (ht_resize, (hash_table_t *, unsigned long)); +static void EXFUN (zero_ht_buckets, (hash_table_t *)); +static ht_record_t * EXFUN (ht_records_list, (hash_table_t *)); +static ht_record_t * EXFUN (ht_lookup, (hash_table_t *, unsigned long)); +static unsigned long EXFUN (ht_insert, (hash_table_t *, ht_record_t *)); +static ht_record_t * EXFUN (ht_delete, (hash_table_t *, unsigned long)); + +static hash_table_t * external_strings = 0; + +DEFINE_PRIMITIVE ("allocate-external-string", Prim_alloc_external_string, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + unsigned long n_bytes = (arg_ulong_integer (1)); + ht_record_t * result = (malloc (n_bytes + 1 + (sizeof (ht_record_t)))); + if (result == 0) + error_bad_range_arg (1); + if (external_strings == 0) + external_strings = (make_hash_table ()); + (HT_RECORD_N_BYTES (result)) = n_bytes; + /* Guarantee zero termination in case used as C string. */ + (((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0'; + PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, result))); + } +} + +DEFINE_PRIMITIVE ("external-string?", Prim_external_string_p, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + SCHEME_OBJECT x = (ARG_REF (1)); + if ((INTEGER_P (x)) && (integer_to_ulong_p (x))) + { + ht_record_t * record; + if (external_strings == 0) + external_strings = (make_hash_table ()); + record = (ht_lookup (external_strings, (integer_to_ulong (x)))); + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (record != 0)); + } + else + PRIMITIVE_RETURN (SHARP_F); + } +} + +DEFINE_PRIMITIVE ("deallocate-external-string", Prim_dealloc_external_string, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + unsigned long n = (arg_ulong_integer (1)); + ht_record_t * record; + if (external_strings == 0) + external_strings = (make_hash_table ()); + record = (ht_delete (external_strings, n)); + if (record == 0) + error_wrong_type_arg (1); + free (record); + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + +DEFINE_PRIMITIVE ("extended-string-length", Prim_extended_string_length, 1, 1, 0) +{ + PRIMITIVE_HEADER (1); + { + unsigned long len; + arg_extended_string (1, (&len)); + PRIMITIVE_RETURN (ulong_to_integer (len)); + } +} + +PTR +DEFUN (arg_extended_string, (n), unsigned int n AND unsigned long * lp) +{ + SCHEME_OBJECT object = (ARG_REF (n)); + if (STRING_P (object)) + { + if (lp != 0) + (*lp) = (STRING_LENGTH (object)); + return (STRING_LOC (object, 0)); + } + else if ((INTEGER_P (object)) && (integer_to_ulong_p (object))) + { + ht_record_t * record; + if (external_strings == 0) + external_strings = (make_hash_table ()); + record = (ht_lookup (external_strings, (integer_to_ulong (object)))); + if (record == 0) + error_wrong_type_arg (n); + if (lp != 0) + (*lp) = (HT_RECORD_N_BYTES (record)); + return (HT_RECORD_PTR (record)); + } + else + { + error_wrong_type_arg (n); + return (0); + } +} + +#define HT_MIN_EXPT 4 +#define HT_MAX_EXPT 24 + +#define EXPT_TO_N(e) ((1 << (e)) - 1) + +static hash_table_t * +DEFUN_VOID (make_hash_table) +{ + unsigned long n = (EXPT_TO_N (HT_MIN_EXPT)); + hash_table_t * table = (malloc (sizeof (hash_table_t))); + if (table == 0) + abort (); + (HT_N_RECORDS (table)) = 0; + (HT_N_BUCKETS (table)) = n; + (HT_BUCKETS (table)) = (malloc (n * (sizeof (ht_record_t *)))); + if ((HT_BUCKETS (table)) == 0) + abort (); + zero_ht_buckets (table); + return (table); +} + +static void +DEFUN (ht_resize, (table, new_n_buckets), + hash_table_t * table AND + unsigned long new_n_buckets) +{ + ht_record_t ** new_buckets + = (malloc (new_n_buckets * (sizeof (ht_record_t *)))); + if (new_buckets != 0) + { + ht_record_t * records = (ht_records_list (table)); + (HT_BUCKETS (table)) = new_buckets; + (HT_N_BUCKETS (table)) = new_n_buckets; + (HT_N_RECORDS (table)) = 0; + zero_ht_buckets (table); + while (records != 0) + { + ht_record_t * next = (HT_RECORD_NEXT (records)); + ht_insert (table, records); + records = next; + } + } +} + +static void +DEFUN (zero_ht_buckets, (table), hash_table_t * table) +{ + ht_record_t ** scan = (HT_BUCKETS (table)); + ht_record_t ** end = (scan + (HT_N_BUCKETS (table))); + while (scan < end) + (*scan++) = 0; +} + +static ht_record_t * +DEFUN (ht_records_list, (table), hash_table_t * table) +{ + ht_record_t ** scan_buckets = (HT_BUCKETS (table)); + ht_record_t ** end_buckets = (scan_buckets + (HT_N_BUCKETS (table))); + ht_record_t * result = 0; + while (scan_buckets < end_buckets) + { + ht_record_t * scan = (*scan_buckets); + while (scan != 0) + { + ht_record_t * next = (HT_RECORD_NEXT (scan)); + (HT_RECORD_NEXT (scan)) = result; + result = scan; + scan = next; + } + (*scan_buckets++) = 0; + } + return (result); +} + +static ht_record_t * +DEFUN (ht_lookup, (table, key), + hash_table_t * table AND + unsigned long key) +{ + unsigned long index = (HT_BUCKET_INDEX (table, key)); + ht_record_t * record = (HT_BUCKET_REF (table, index)); + while (record != 0) + { + if ((HT_RECORD_KEY (record)) == key) + return (record); + record = (HT_RECORD_NEXT (record)); + } + return (0); +} + +static unsigned long +DEFUN (ht_insert, (table, record), + hash_table_t * table AND + ht_record_t * record) +{ + unsigned long index = (HT_BUCKET_INDEX (table, (HT_RECORD_KEY (record)))); + ht_record_t * scan = (HT_BUCKET_REF (table, index)); + (HT_RECORD_NEXT (record)) = 0; + if (scan == 0) + (HT_BUCKET_REF (table, index)) = record; + else + { + while ((HT_RECORD_NEXT (scan)) != 0) + scan = (HT_RECORD_NEXT (scan)); + (HT_RECORD_NEXT (scan)) = record; + } + (HT_N_RECORDS (table)) += 1; + if ((HT_N_RECORDS (table)) >= (HT_N_BUCKETS (table))) + { + unsigned int e = HT_MIN_EXPT; + while (e <= HT_MAX_EXPT) + { + unsigned long n = (EXPT_TO_N (e)); + if (n > (HT_N_BUCKETS (table))) + { + ht_resize (table, n); + break; + } + e += 1; + } + } + return (HT_RECORD_KEY (record)); +} + +static ht_record_t * +DEFUN (ht_delete, (table, key), + hash_table_t * table AND + unsigned long key) +{ + unsigned long index = (HT_BUCKET_INDEX (table, key)); + ht_record_t * scan = (HT_BUCKET_REF (table, index)); + ht_record_t * prev = 0; + while (1) + { + if (scan == 0) + return (0); + if ((HT_RECORD_KEY (scan)) == key) + break; + prev = scan; + scan = (HT_RECORD_NEXT (scan)); + } + if (prev == 0) + (HT_BUCKET_REF (table, index)) = (HT_RECORD_NEXT (scan)); + else + (HT_RECORD_NEXT (prev)) = (HT_RECORD_NEXT (scan)); + (HT_N_RECORDS (table)) -= 1; + if ((HT_N_RECORDS (table)) < (HT_SHRINK_POINT (table))) + { + unsigned int e = HT_MAX_EXPT; + while (e >= HT_MIN_EXPT) + { + unsigned long n = (EXPT_TO_N (e)); + if (n < (HT_N_BUCKETS (table))) + { + ht_resize (table, n); + break; + } + e += 1; + } + } + return (scan); +} diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 8610ed670..2ffb9a669 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: version.h,v 11.176 2000/12/05 21:23:49 cph Exp $ +$Id: version.h,v 11.177 2001/01/04 22:07:45 cph Exp $ -Copyright (c) 1988-2000 Massachusetts Institute of Technology +Copyright (c) 1988-2001 Massachusetts Institute of Technology This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -24,7 +24,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. /* Scheme system release version */ #ifndef SCHEME_RELEASE -#define SCHEME_RELEASE "7.5.12" +#define SCHEME_RELEASE "7.5.13" #endif /* Microcode release version */ @@ -33,5 +33,5 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define SCHEME_VERSION 14 #endif #ifndef SCHEME_SUBVERSION -#define SCHEME_SUBVERSION 0 +#define SCHEME_SUBVERSION 1 #endif