diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm index dfa92e8..1954079 100644 --- a/src/imail/imail-util.scm +++ b/src/imail/imail-util.scm @@ -423,18 +423,13 @@ USA. (define (read-file-into-xstring pathname) (call-with-binary-input-file pathname (lambda (port) - (let ((n-bytes ((port/operation port 'LENGTH) port))) - (let ((xstring (allocate-external-string n-bytes))) - (let loop ((start 0)) - (if (< start n-bytes) - (let ((n-read (read-substring! xstring 0 n-bytes port))) - (if (= n-read 0) - (error "Failed to read complete file:" - (+ start n-read) n-bytes pathname)) - (loop (+ start n-read))))) - xstring))))) + (map-read-only-external-string-from-channel + (port/input-channel port) + 0 + ((port/operation port 'LENGTH) port))))) (define (call-with-input-xstring xstring position receiver) + (xstring-expect-sequential-access xstring 0 (xstring-length xstring)) (let ((port (open-xstring-input-port xstring position))) (let ((value (receiver port))) (close-port port) @@ -475,6 +470,7 @@ USA. (set-istate-buffer-start! state start) (set-istate-buffer-end! state end) (xsubstring-move! xstring start end buffer 0))) + (xstring-expect-no-access-soon xstring start end) #t))))) (define (xstring-input-port/discard-chars port delimiters) diff --git a/src/microcode/osio.h b/src/microcode/osio.h index a5979a2..a48651a 100644 --- a/src/microcode/osio.h +++ b/src/microcode/osio.h @@ -109,5 +109,13 @@ extern int OS_test_select_registry (select_registry_t registry, int blockp); extern int OS_test_select_descriptor (int fd, int blockp, unsigned int mode); + +/* Kludgey partial memory-mapped I/O abstraction */ + +extern const int OS_have_memory_mapped_io_p; + +extern void * OS_map_read_only_memory_from_channel + (Tchannel channel, off_t offset, size_t length); +extern void OS_unmap_memory (void * address, size_t length); #endif /* SCM_OSIO_H */ diff --git a/src/microcode/ostop.h b/src/microcode/ostop.h index 6c901d2..219c2ab 100644 --- a/src/microcode/ostop.h +++ b/src/microcode/ostop.h @@ -41,6 +41,7 @@ extern void OS_restore_external_state (void); extern const char * OS_error_code_to_message (unsigned int code); extern void OS_expect_sequential_access (void *start, void *end); extern void OS_expect_normal_access (void *start, void *end); +extern void OS_expect_no_access_soon (void *start, void *end); extern void OS_free_pages (void *start, void *end); #endif /* SCM_OSTOP_H */ diff --git a/src/microcode/string.c b/src/microcode/string.c index f3d1214..88af494 100644 --- a/src/microcode/string.c +++ b/src/microcode/string.c @@ -27,6 +27,9 @@ USA. /* String primitives. */ #include "scheme.h" +#include "osio.h" +#include "osscheme.h" +#include "ostop.h" #include "prims.h" SCHEME_OBJECT @@ -514,10 +517,30 @@ struct ht_record_s { ht_record_t * next; unsigned long n_bytes; + void (* deallocator) (ht_record_t *); + void * pointer; }; -#define HT_RECORD_PTR(record) ((void *) ((record) + 1)) -#define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1)) +struct ht_record_inline +{ + ht_record_t record; + /* We're not supposed to use C99, right? Foo! */ + unsigned char data [1]; +}; + +static size_t +ht_record_allocation_size (size_t n_bytes) +{ + if (SIZE_MAX - n_bytes < (sizeof (struct ht_record_inline))) + /* malloc will presumably choke on this. */ + return (SIZE_MAX); + else + return ((sizeof (struct ht_record_inline)) - 1 + n_bytes); +} + +#define HT_RECORD_DEALLOCATOR(record) ((record) -> deallocator) +#define HT_RECORD_PTR(record) ((record) -> pointer) +#define HT_RECORD_KEY(record) ((unsigned long) (HT_RECORD_PTR (record))) #define HT_RECORD_NEXT(record) ((record) -> next) #define HT_RECORD_N_BYTES(record) ((record) -> n_bytes) @@ -545,16 +568,36 @@ static ht_record_t * ht_delete (hash_table_t *, unsigned long); static hash_table_t * external_strings = 0; +static void +free_external_string (ht_record_t * record) +{ + free (record); +} + +static void +unmap_external_string (ht_record_t * record) +{ + OS_unmap_memory ((HT_RECORD_PTR (record)), (HT_RECORD_N_BYTES (record))); + free (record); +} + 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) + ht_record_t * result; + void * ptr; + struct ht_record_inline * result_inline + = (malloc (ht_record_allocation_size (n_bytes + 1))); + if (result_inline == 0) error_bad_range_arg (1); + result = (& (result_inline -> record)); + ptr = (result_inline -> data); if (external_strings == 0) external_strings = (make_hash_table ()); + (HT_RECORD_DEALLOCATOR (result)) = (&free_external_string); + (HT_RECORD_PTR (result)) = ptr; (HT_RECORD_N_BYTES (result)) = n_bytes; /* Guarantee zero termination in case used as C string. */ (((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0'; @@ -562,6 +605,74 @@ DEFINE_PRIMITIVE ("ALLOCATE-EXTERNAL-STRING", Prim_alloc_external_string, 1, 1, } } +DEFINE_PRIMITIVE ("HAVE-MEMORY-MAPPED-I/O?", Prim_have_memory_mapped_io_p, 0, 0, 0) +{ + PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_have_memory_mapped_io_p)); +} + +static void +free_action (void * environment) +{ + void * pointer = (* ((void **) environment)); + if (pointer != 0) + OS_free (pointer); +} + +DEFINE_PRIMITIVE ("MAP-READ-ONLY-EXTERNAL-STRING-FROM-CHANNEL", Prim_map_read_only_external_string_from_channel, 3, 3, 0) +{ + PRIMITIVE_HEADER (3); + { + Tchannel channel = (arg_channel (1)); + off_t offset = (arg_index_integer_to_intmax (2, OFF_T_MAX)); + size_t length = (arg_index_integer_to_intmax (3, SIZE_MAX)); + ht_record_t * record = 0; + void * address; + + transaction_begin (); + transaction_record_action (tat_abort, (&free_action), (&record)); + record = (OS_malloc (sizeof (*record))); + address = (OS_map_read_only_memory_from_channel (channel, offset, length)); + transaction_commit (); + + (HT_RECORD_DEALLOCATOR (record)) = (&unmap_external_string); + (HT_RECORD_PTR (record)) = address; + (HT_RECORD_N_BYTES (record)) = length; + PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, record))); + } +} + +#define XSTRING_MADVICE_PRIMITIVE(OPERATION) \ +{ \ + PRIMITIVE_HEADER (3); \ + { \ + unsigned long n = (arg_ulong_integer (1)); \ + intmax_t end = (arg_index_integer_to_intmax (3, SIZE_MAX)); \ + intmax_t start = (arg_index_integer_to_intmax (2, end)); \ + ht_record_t * record = 0; \ + unsigned char * ptr; \ + \ + if (external_strings != 0) \ + record = (ht_lookup (external_strings, n)); \ + if (record == 0) \ + error_bad_range_arg (1); \ + \ + if ((HT_RECORD_N_BYTES (record)) < end) \ + error_bad_range_arg (3); \ + \ + ptr = (HT_RECORD_PTR (record)); \ + OPERATION ((ptr + start), (ptr + end)); \ + \ + PRIMITIVE_RETURN (UNSPECIFIC); \ + } \ +} + +DEFINE_PRIMITIVE ("EXPECT-NO-ACCESS-SOON-TO-EXTERNAL-STRING", Prim_expect_no_access_soon_to_external_string, 3, 3, 0) + XSTRING_MADVICE_PRIMITIVE (OS_expect_no_access_soon) +DEFINE_PRIMITIVE ("EXPECT-NORMAL-ACCESS-TO-EXTERNAL-STRING", Prim_expect_normal_access_to_external_string, 3, 3, 0) + XSTRING_MADVICE_PRIMITIVE (OS_expect_normal_access) +DEFINE_PRIMITIVE ("EXPECT-SEQUENTIAL-ACCESS-TO-EXTERNAL-STRING", Prim_expect_sequential_access_to_external_string, 3, 3, 0) + XSTRING_MADVICE_PRIMITIVE (OS_expect_sequential_access) + DEFINE_PRIMITIVE ("EXTERNAL-STRING?", Prim_external_string_p, 1, 1, 0) { PRIMITIVE_HEADER (1); @@ -591,7 +702,7 @@ DEFINE_PRIMITIVE ("DEALLOCATE-EXTERNAL-STRING", Prim_dealloc_external_string, 1, record = (ht_delete (external_strings, n)); if (record == 0) error_wrong_type_arg (1); - free (record); + (* (HT_RECORD_DEALLOCATOR (record))) (record); PRIMITIVE_RETURN (UNSPECIFIC); } } diff --git a/src/microcode/syscall.h b/src/microcode/syscall.h index 2abbb12..f996119 100644 --- a/src/microcode/syscall.h +++ b/src/microcode/syscall.h @@ -78,6 +78,7 @@ enum syscall_names syscall_malloc, syscall_mkdir, syscall_mktime, + syscall_mmap, syscall_ntp_adjtime, syscall_ntp_gettime, syscall_open, diff --git a/src/microcode/uxio.c b/src/microcode/uxio.c index 3536207..3aca107 100644 --- a/src/microcode/uxio.c +++ b/src/microcode/uxio.c @@ -787,3 +787,35 @@ OS_test_select_descriptor (int fd, int blockp, unsigned int mode) } #endif /* not HAVE_POLL */ + +#ifndef HAVE_MMAP + +const int OS_have_memory_mapped_io_p = 0; + +#else + +const int OS_have_memory_mapped_io_p = 1; + +void +OS_unmap_memory (void * address, size_t length) +{ + (void) munmap (address, length); +} + +void * +OS_map_read_only_memory_from_channel (Tchannel channel, + off_t offset, size_t length) +{ + int fd = (CHANNEL_DESCRIPTOR (channel)); + void * address; + + /* FIXME: Should assign a different system call name to different + protection and flags, to report errors more precisely. */ + STD_PTR_SYSTEM_CALL + (syscall_mmap, address, + (mmap (0, length, PROT_READ, MAP_PRIVATE, fd, offset))); + + return (address); +} + +#endif diff --git a/src/microcode/uxtop.c b/src/microcode/uxtop.c index 2938246..ed11976 100644 --- a/src/microcode/uxtop.c +++ b/src/microcode/uxtop.c @@ -463,6 +463,7 @@ static const char * syscall_names_table [] = "malloc", "mkdir", "mktime", + "mmap", "ntp_adjtime", "ntp_gettime", "open", @@ -638,6 +639,19 @@ OS_expect_normal_access (void *start, void *end) #endif } +void +OS_expect_no_access_soon (void *start, void *end) +{ + void *addr; + size_t len; + overestimate_pages (start, end, (&addr), (&len)); + /* Beware! Don't use MADV_DONTNEED. See below about Linux's lunacy + here. */ +#if ((defined (HAVE_POSIX_MADVISE)) && (defined (POSIX_MADV_DONTNEED))) + (void) posix_madvise (addr, len, POSIX_MADV_DONTNEED); +#endif +} + /* Brain-damaged Linux uses MADV_DONTNEED to mean the destructive operation that everyone else means by MADV_FREE. Everywhere else, (POSIX_)MADV_DONTNEED is a nondestructive operation which is useless diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f86084b..05ff993 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -945,6 +945,7 @@ USA. list->string make-string make-vector-8b + map-read-only-external-string-from-channel reverse-string reverse-string! reverse-substring @@ -1059,6 +1060,9 @@ USA. vector-8b-find-previous-char-ci vector-8b-ref vector-8b-set! + xstring-expect-no-access-soon + xstring-expect-normal-access + xstring-expect-sequential-access xstring-fill! xstring-length xstring-move! @@ -3241,6 +3245,8 @@ USA. (export (runtime socket) channel-descriptor open-channel) + (export (runtime string) + channel-descriptor) (export (runtime subprocess) channel-descriptor) (export (runtime microcode-errors) diff --git a/src/runtime/string.scm b/src/runtime/string.scm index fe0de39..19ce6a7 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -1523,6 +1523,33 @@ USA. ((ucode-primitive allocate-external-string) n-bytes) n-bytes))))) +(define (map-read-only-external-string-from-channel channel offset length) + (without-interrupts + (lambda () + (add-to-gc-finalizer! + external-strings + (make-external-string + ((ucode-primitive MAP-READ-ONLY-EXTERNAL-STRING-FROM-CHANNEL 3) + (channel-descriptor channel) + offset + length) + length))))) + +(define (xstring-expect-no-access-soon xstring start end) + (if (external-string? xstring) + ((ucode-primitive EXPECT-NO-ACCESS-SOON-TO-EXTERNAL-STRING 3) + (external-string-descriptor xstring) start end))) + +(define (xstring-expect-normal-access xstring start end) + (if (external-string? xstring) + ((ucode-primitive EXPECT-NORMAL-ACCESS-TO-EXTERNAL-STRING 3) + (external-string-descriptor xstring) start end))) + +(define (xstring-expect-sequential-access xstring start end) + (if (external-string? xstring) + ((ucode-primitive EXPECT-SEQUENTIAL-ACCESS-TO-EXTERNAL-STRING 3) + (external-string-descriptor xstring) start end))) + (define (external-string-ref string index) (ascii->char ((ucode-primitive read-byte-from-memory)