source: project/release/4/memory-mapped-files/memory-mapped-files.scm @ 31138

Last change on this file since 31138 was 31138, checked in by felix winkelmann, 6 years ago

added preliminary eggs for extraction from core libraries

File size: 5.0 KB
Line 
1;;;; memory-mapped file access for UNIX and Windows
2
3
4#>
5#ifdef WIN32
6
7#define PROT_NONE       0
8#define PROT_READ       1
9#define PROT_WRITE      2
10#define PROT_EXEC       4
11#define MAP_FILE        0
12#define MAP_SHARED      1
13#define MAP_PRIVATE     2
14#define MAP_FIXED       0x10
15#define MAP_ANONYMOUS   0x20
16
17// This value is available starting with Windows XP with SP2 
18// and Windows Server 2003 with SP1.
19#ifndef FILE_MAP_EXECUTE
20#define FILE_MAP_EXECUTE 0x20
21#endif//FILE_MAP_EXECUTE
22
23static int page_flags[] =
24{
25    0,
26    PAGE_READONLY,
27    PAGE_READWRITE,
28    PAGE_READWRITE,
29    PAGE_EXECUTE_READ,
30    PAGE_EXECUTE_READ,
31    PAGE_EXECUTE_READWRITE
32};
33
34static int file_flags[] =
35{
36    0,
37    FILE_MAP_READ,
38    FILE_MAP_READ|FILE_MAP_WRITE,
39    FILE_MAP_READ|FILE_MAP_WRITE,
40    FILE_MAP_READ|FILE_MAP_EXECUTE,
41    FILE_MAP_READ|FILE_MAP_EXECUTE,
42    FILE_MAP_READ|FILE_MAP_WRITE|FILE_MAP_EXECUTE
43};
44
45void* mmap(void* addr,int len,int prot,int flags,int fd,int off)
46{
47    HANDLE hMap;
48    HANDLE hFile;
49
50    void* ptr;
51
52    if ((flags & MAP_FIXED) || (flags & MAP_PRIVATE) || (flags & MAP_ANONYMOUS))
53    {
54        errno = EINVAL;
55        return (void*)-1;
56    }
57
58    /*
59     * We must cast because _get_osfhandle returns intptr_t, but it must
60     * be compared with INVALID_HANDLE_VALUE, which is a HANDLE type.
61     * Who comes up with this shit?
62     */
63    hFile = (HANDLE)_get_osfhandle(fd);
64    if (hFile == INVALID_HANDLE_VALUE)
65    {
66        return (void*)-1;
67    }
68
69    hMap = CreateFileMapping(
70            hFile,
71            NULL,
72            page_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
73            0,
74            0,
75            NULL);
76
77    if (hMap == INVALID_HANDLE_VALUE)
78    {
79        set_last_errno();
80        return (void*)-1;
81    }
82
83    ptr = MapViewOfFile(
84            hMap,
85            file_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
86            0,
87            off,
88            len);
89
90    if (ptr == NULL)
91    {
92        set_last_errno();
93        ptr = (void*)-1;
94    }
95
96    CloseHandle(hMap);
97
98    return ptr;
99}
100
101int munmap(void* addr,int len)
102{
103    if (UnmapViewOfFile(addr))
104    {
105        errno = 0;
106        return 0;
107    }
108    set_last_errno();
109    return -1;
110}
111#else
112#include <sys/mman.h>
113#endif
114
115int is_bad_mmap(void* p)
116{
117    void* bad_ptr;
118    bad_ptr = (void*)-1;
119    return p == bad_ptr;
120}
121
122<#
123
124
125(module memory-mapped-files (prot/none
126                             prot/read
127                             prot/write
128                             prot/exec
129                             map/file 
130                             map/shared
131                             map/private
132                             map/fixed
133                             map/anonymous
134                             map-file-to-memory
135                             unmap-file-from-memory
136                             memory-mapped-file-pointer
137                             memory-mapped-file?)
138
139  (import scheme chicken foreign)
140
141(define posix-error
142  (let ([strerror (foreign-lambda c-string "strerror" int)]
143        [string-append string-append] )
144    (lambda (type loc msg . args)
145      (let ([rn (##sys#update-errno)])
146        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
147
148;;; Memory mapped I/O:
149
150(define-foreign-variable _prot_read int "PROT_READ")
151(define-foreign-variable _prot_write int "PROT_WRITE")
152(define-foreign-variable _prot_exec int "PROT_EXEC")
153(define-foreign-variable _prot_none int "PROT_NONE")
154
155(define prot/read _prot_read)
156(define prot/write _prot_write)
157(define prot/exec _prot_exec)
158(define prot/none _prot_none)
159
160(define-foreign-variable _map_fixed int "MAP_FIXED")
161(define-foreign-variable _map_shared int "MAP_SHARED")
162(define-foreign-variable _map_private int "MAP_PRIVATE")
163(define-foreign-variable _map_anonymous int "MAP_ANON")
164(define-foreign-variable _map_file int "MAP_FILE")
165
166(define map/fixed _map_fixed)
167(define map/shared _map_shared)
168(define map/private _map_private)
169(define map/anonymous _map_anonymous)
170(define map/file _map_file)
171
172(define map-file-to-memory
173  (let ((mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer))
174        (bad-mmap? (foreign-lambda bool "is_bad_mmap" c-pointer)))
175    (lambda (addr len prot flag fd . off)
176      (let ((addr (if (not addr) (##sys#null-pointer) addr))
177            (off (if (pair? off) (car off) 0)) )
178        (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
179          (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
180        (let ((addr2 (mmap addr len prot flag fd off)))
181          (when (bad-mmap? addr2)
182            (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
183          (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
184
185(define unmap-file-from-memory
186  (let ((munmap (foreign-lambda int "munmap" c-pointer integer)) )
187    (lambda (mmap . len)
188      (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
189      (let ((len (if (pair? len) (car len) (##sys#slot mmap 2))))
190        (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
191          (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
192
193(define (memory-mapped-file-pointer mmap)
194  (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
195  (##sys#slot mmap 1) )
196
197(define (memory-mapped-file? x)
198  (##sys#structure? x 'mmap) )
199
200)
Note: See TracBrowser for help on using the repository browser.