Ignore:
Timestamp:
Nov 18, 2009, 7:21:48 AM (10 years ago)
Author:
gb
Message:

Separate OS-level file-mapping stuff from other file-mapping stuff,
provide implementations of MAP-FILE-TO-IVECTOR, UNMAP-IVECTOR, etc.
for Windows. Fixes ticket:627.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/linux-files.lisp

    r13187 r13209  
    20642064    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
    20652065
     2066#+windows-target
     2067(defloadvar *windows-allocation-granularity*
     2068    (rlet ((info #>SYSTEM_INFO))
     2069      (#_GetSystemInfo info)
     2070      (pref info #>SYSTEM_INFO.dwAllocationGranularity)))
     2071
    20662072#-windows-target
    2067 (progn
     2073(defun %memory-map-fd (fd len bits-per-element)
     2074  (let* ((nbytes (+ *host-page-size*
     2075                    (logandc2 (+ len
     2076                                 (1- *host-page-size*))
     2077                              (1- *host-page-size*))))         
     2078         (ndata-elements
     2079          (ash len
     2080               (ecase bits-per-element
     2081                 (1 3)
     2082                 (8 0)
     2083                 (16 -1)
     2084                 (32 -2)
     2085                 (64 -3))))
     2086         (nalignment-elements
     2087          (ash target::nbits-in-word
     2088               (ecase bits-per-element
     2089                 (1 0)
     2090                 (8 -3)
     2091                 (16 -4)
     2092                 (32 -5)
     2093                 (64 -6)))))
     2094    (if (>= (+ ndata-elements nalignment-elements)
     2095            array-total-size-limit)
     2096      (progn
     2097        (fd-close fd)
     2098        (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
     2099      (let* ((addr (#_mmap (%null-ptr)
     2100                           nbytes
     2101                           #$PROT_NONE
     2102                           (logior #$MAP_ANON #$MAP_PRIVATE)
     2103                           -1
     2104                           0)))             
     2105        (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
     2106          (let* ((errno (%get-errno)))
     2107            (fd-close fd)
     2108            (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
     2109              ;;; Remap the first page so that we can put a vector header
     2110              ;;; there; use the first word on the first page to remember
     2111              ;;; the file descriptor.
     2112          (progn
     2113            (#_mmap addr
     2114                    *host-page-size*
     2115                    (logior #$PROT_READ #$PROT_WRITE)
     2116                    (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
     2117                    -1
     2118                    0)
     2119            (setf (pref addr :int) fd)
     2120            (let* ((header-addr (%inc-ptr addr (- *host-page-size*
     2121                                                            (* 2 target::node-size)))))
     2122             
     2123              (when (> len 0)
     2124                (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
     2125                  (unless (eql target-addr
     2126                               (#_mmap target-addr
     2127                                       len
     2128                                       #$PROT_READ
     2129                                       (logior #$MAP_PRIVATE #$MAP_FIXED)
     2130                                       fd
     2131                                       0))
     2132                    (let* ((errno (%get-errno)))
     2133                      (fd-close fd)
     2134                      (#_munmap addr nbytes)
     2135                      (error "Mapping failed: ~a" (%strerror errno))))))
     2136              (values header-addr ndata-elements nalignment-elements))))))))
     2137
     2138#+windows-target
     2139(defun %memory-map-fd (fd len bits-per-element)
     2140  (let* ((nbytes (+ *windows-allocation-granularity*
     2141                    (logandc2 (+ len
     2142                                 (1- *windows-allocation-granularity*))
     2143                              (1- *windows-allocation-granularity*))))         
     2144         (ndata-elements
     2145          (ash len
     2146               (ecase bits-per-element
     2147                 (1 3)
     2148                 (8 0)
     2149                 (16 -1)
     2150                 (32 -2)
     2151                 (64 -3))))
     2152         (nalignment-elements
     2153          (ash target::nbits-in-word
     2154               (ecase bits-per-element
     2155                 (1 0)
     2156                 (8 -3)
     2157                 (16 -4)
     2158                 (32 -5)
     2159                 (64 -6)))))
     2160    (if (>= (+ ndata-elements nalignment-elements)
     2161            array-total-size-limit)
     2162      (progn
     2163        (fd-close fd)
     2164        (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
     2165      (let* ((mapping (#_CreateFileMappingA (%int-to-ptr fd) (%null-ptr) #$PAGE_READONLY 0 0 (%null-ptr))))
     2166        (if (%null-ptr-p mapping)
     2167          (let* ((err (#_GetLastError)))
     2168            (fd-close fd)
     2169            (error "Couldn't create a file mapping - ~a." (%windows-error-string err)))
     2170          (loop
     2171            (let* ((base (#_VirtualAlloc (%null-ptr) nbytes #$MEM_RESERVE #$PAGE_NOACCESS)))
     2172              (if (%null-ptr-p base)
     2173                (let* ((err (#_GetLastError)))
     2174                  (#_CloseHandle mapping)
     2175                  (fd-close fd)
     2176                  (error "Couldn't reserve ~d bytes of address space for mapped file - ~a"
     2177                         nbytes (%windows-error-string err)))
     2178                ;; Now we have to free the memory and hope that we can reallocate it ...
     2179                (progn
     2180                  (#_VirtualFree base 0 #$MEM_RELEASE)
     2181                  (unless (%null-ptr-p (#_VirtualAlloc base *windows-allocation-granularity* #$MEM_RESERVE #$PAGE_NOACCESS))
     2182                    (let* ((fptr (%inc-ptr base *windows-allocation-granularity*)))
     2183                      (if (%null-ptr-p (#_MapViewOfFileEx mapping #$FILE_MAP_READ 0 0 0 fptr))
     2184                        (#_VirtualFree base 0 #$MEM_RELEASE)
     2185                        (let* ((prefix-page (%inc-ptr base (- *windows-allocation-granularity*
     2186                                                              *host-page-size*))))
     2187                          (#_VirtualAlloc prefix-page *host-page-size* #$MEM_COMMIT #$PAGE_READWRITE)
     2188                          (setf (paref prefix-page (:* :address) 0) mapping
     2189                                (paref prefix-page (:* :address) 1) (%int-to-ptr fd))
     2190                          (return (values
     2191                                   (%inc-ptr prefix-page (- *host-page-size*
     2192                                                            (* 2 target::node-size)))
     2193                                   ndata-elements
     2194                                   nalignment-elements)))))))))))))))
     2195                       
     2196
     2197
    20682198(defun map-file-to-ivector (pathname element-type)
    20692199  (let* ((upgraded-type (upgraded-array-element-type element-type))
     
    20802210          (if (< len 0)
    20812211            (signal-file-error fd pathname)
    2082             (let* ((nbytes (+ *host-page-size*
    2083                               (logandc2 (+ len
    2084                                            (1- *host-page-size*))
    2085                                         (1- *host-page-size*))))
    2086 
    2087                    (ndata-elements
    2088                     (ash len
    2089                          (ecase bits-per-element
    2090                            (1 3)
    2091                            (8 0)
    2092                            (16 -1)
    2093                            (32 -2)
    2094                            (64 -3))))
    2095                    (nalignment-elements
    2096                     (ash target::nbits-in-word
    2097                          (ecase bits-per-element
    2098                            (1 0)
    2099                            (8 -3)
    2100                            (16 -4)
    2101                            (32 -5)
    2102                            (64 -6)))))
    2103               (if (>= (+ ndata-elements nalignment-elements)
    2104                       array-total-size-limit)
    2105                 (progn
    2106                   (fd-close fd)
    2107                   (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
    2108                 (let* ((addr (#_mmap (%null-ptr)
    2109                                      nbytes
    2110                                      #$PROT_NONE
    2111                                      (logior #$MAP_ANON #$MAP_PRIVATE)
    2112                                      -1
    2113                                      0)))             
    2114                   (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
    2115                     (let* ((errno (%get-errno)))
    2116                       (fd-close fd)
    2117                       (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
    2118               ;;; Remap the first page so that we can put a vector header
    2119               ;;; there; use the first word on the first page to remember
    2120               ;;; the file descriptor.
    2121                     (progn
    2122                       (#_mmap addr
    2123                               *host-page-size*
    2124                               (logior #$PROT_READ #$PROT_WRITE)
    2125                               (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
    2126                               -1
    2127                               0)
    2128                       (setf (pref addr :int) fd)
    2129                       (let* ((header-addr (%inc-ptr addr (- *host-page-size*
    2130                                                             (* 2 target::node-size)))))
    2131                         (setf (pref header-addr :unsigned-long)
    2132                               (logior (element-type-subtype upgraded-type)
    2133                                       (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
    2134                         (when (> len 0)
    2135                           (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
    2136                             (unless (eql target-addr
    2137                                          (#_mmap target-addr
    2138                                                  len
    2139                                                  #$PROT_READ
    2140                                                  (logior #$MAP_PRIVATE #$MAP_FIXED)
    2141                                                  fd
    2142                                                  0))
    2143                               (let* ((errno (%get-errno)))
    2144                                 (fd-close fd)
    2145                                 (#_munmap addr nbytes)
    2146                                 (error "Mapping failed: ~a" (%strerror errno))))))
    2147                         (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
     2212            (multiple-value-bind (header-address ndata-elements nalignment-elements)
     2213                (%memory-map-fd fd len bits-per-element)
     2214              (setf (%get-natural header-address 0)
     2215                    (logior (element-type-subtype upgraded-type)
     2216                            (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
     2217              (with-macptrs ((v (%inc-ptr header-address target::fulltag-misc)))
    21482218                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
    21492219                            ;; Tell some parts of Clozure CL - notably the
     
    21572227                                        :displaced-to vector
    21582228                                        :adjustable t
    2159                                         :displaced-index-offset nalignment-elements)))))))))))))))
     2229                                        :displaced-index-offset nalignment-elements))))))))))
    21602230
    21612231(defun map-file-to-octet-vector (pathname)
     
    21782248                 target::node-size)))))
    21792249
    2180  
     2250
     2251#-windows-target
     2252(defun %unmap-file (data-address size-in-octets)
     2253  (let* ((base-address (%inc-ptr data-address (- *host-page-size*)))
     2254         (fd (pref base-address :int)))
     2255    (#_munmap base-address (+ *host-page-size* size-in-octets))
     2256    (fd-close fd)))
     2257
     2258#+windows-target
     2259(defun %unmap-file (data-address size-in-octets)
     2260  (declare (ignore size-in-octets))
     2261  (let* ((prefix-page (%inc-ptr data-address (- *host-page-size*)))
     2262         (prefix-allocation (%inc-ptr data-address (- *windows-allocation-granularity*)))
     2263         (mapping (paref prefix-page (:* :address) 0))
     2264         (fd (%ptr-to-int (paref prefix-page (:* :address) 1))))
     2265    (#_UnmapViewOfFile data-address)
     2266    (#_CloseHandle mapping)
     2267    (#_VirtualFree prefix-allocation 0 #$MEM_RELEASE)
     2268    (fd-close fd)))
     2269
     2270   
     2271
    21812272;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
    21822273;;; this should be called at most once for any such object.
     
    21842275  (multiple-value-bind (data-address size-in-octets)
    21852276      (mapped-vector-data-address-and-size displaced-vector)
    2186   (let* ((v (array-displacement displaced-vector))
    2187          (base-address (%inc-ptr data-address (- *host-page-size*)))
    2188          (fd (pref base-address :int)))
     2277  (let* ((v (array-displacement displaced-vector)))
    21892278      (let* ((element-type (array-element-type displaced-vector)))
    21902279        (adjust-array displaced-vector 0
     
    21942283      (with-lock-grabbed (*heap-ivector-lock*)
    21952284        (setq *heap-ivectors* (delete v *heap-ivectors*)))
    2196       (#_munmap base-address (+ size-in-octets *host-page-size*))     
    2197       (fd-close fd)
     2285      (%unmap-file data-address size-in-octets)
    21982286      t)))
    21992287
     
    22012289  (unmap-ivector v))
    22022290
     2291#-windows-target
     2292(progn
    22032293(defun lock-mapped-vector (v)
    22042294  (multiple-value-bind (address nbytes)
     
    22392329    (percentage-of-resident-pages address nbytes)))
    22402330)
     2331
    22412332
    22422333#+windows-target
Note: See TracChangeset for help on using the changeset viewer.