Changeset 6417 for branches/x8664-call


Ignore:
Timestamp:
May 4, 2007, 2:20:02 PM (13 years ago)
Author:
gb
Message:

Move *host-page-size* here.
Add file-mapping primitives.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/x8664-call/ccl/level-1/linux-files.lisp

    r6332 r6417  
    11471147(defun yield ()
    11481148  (#_sched_yield))
     1149
     1150(defloadvar *host-page-size* (#_getpagesize))
     1151
     1152;;(assert (= (logcount *host-page-size*) 1))
     1153
     1154(defun map-file-to-ivector (pathname element-type)
     1155  (let* ((upgraded-type (upgraded-array-element-type element-type))
     1156         (upgraded-ctype (specifier-type upgraded-type)))
     1157    (unless (and (typep upgraded-ctype 'numeric-ctype)
     1158                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
     1159      (error "Invalid element-type: ~s" element-type))
     1160    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
     1161                                                (numeric-ctype-low upgraded-ctype))))
     1162           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
     1163      (if (< fd 0)
     1164        (signal-file-error fd pathname)
     1165        (let* ((len (fd-size fd)))
     1166          (if (< len 0)
     1167            (signal-file-error fd pathname)
     1168            (let* ((nbytes (+ *host-page-size*
     1169                              (logandc2 (+ len
     1170                                           (1- *host-page-size*))
     1171                                        (1- *host-page-size*))))
     1172                   (addr (#_mmap +null-ptr+
     1173                                 nbytes
     1174                                 #$PROT_NONE
     1175                                 (logior #$MAP_ANON #$MAP_PRIVATE)
     1176                                 -1
     1177                                 0))
     1178                   (ndata-elements
     1179                    (ash len
     1180                         (ecase bits-per-element
     1181                           (1 3)
     1182                           (8 0)
     1183                           (16 -1)
     1184                           (32 -2)
     1185                           (64 -3))))
     1186                   (nalignment-elements
     1187                    (ash target::nbits-in-word
     1188                         (ecase bits-per-element
     1189                           (1 0)
     1190                           (8 -3)
     1191                           (16 -4)
     1192                           (32 -5)
     1193                           (64 -6)))))
     1194              (if (eql addr (%int-to-ptr -1)) ; #$MAP_FAILED
     1195                (let* ((errno (%get-errno)))
     1196                  (fd-close fd)
     1197                  (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
     1198              ;;; Remap the first page so that we can put a vector header
     1199              ;;; there; use the first word on the first page to remember
     1200              ;;; the file descriptor.
     1201                (progn
     1202                  (#_mmap addr
     1203                          *host-page-size*
     1204                          (logior #$PROT_READ #$PROT_WRITE)
     1205                          (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
     1206                          -1
     1207                          0)
     1208                  (setf (pref addr :int) fd)
     1209                  (let* ((header-addr (%inc-ptr addr (- *host-page-size*
     1210                                                        (* 2 target::node-size)))))
     1211                    (setf (pref header-addr :unsigned-long)
     1212                          (logior (element-type-subtype upgraded-type)
     1213                                  (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
     1214                    (when (> len 0)
     1215                      (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
     1216                        (unless (eql target-addr
     1217                                     (#_mmap target-addr
     1218                                             len
     1219                                             #$PROT_READ
     1220                                             (logior #$MAP_PRIVATE #$MAP_FIXED)
     1221                                             fd
     1222                                             0))
     1223                          (let* ((errno (%get-errno)))
     1224                            (fd-close fd)
     1225                            (#_munmap addr nbytes)
     1226                            (error "Mapping failed: ~a" (%strerror errno))))))
     1227                    (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
     1228                      (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
     1229                        ;; Tell some parts of OpenMCL - notably the
     1230                        ;; printer - that this thing off in foreign
     1231                        ;; memory is a real lisp object and not
     1232                        ;; "bogus".
     1233                        (with-lock-grabbed (*heap-ivector-lock*)
     1234                          (push vector *heap-ivectors*))
     1235                        (make-array ndata-elements
     1236                                    :element-type upgraded-type
     1237                                    :displaced-to vector
     1238                                    :adjustable t
     1239                                    :displaced-index-offset nalignment-elements)))))))))))))
     1240
     1241(defun map-file-to-octet-vector (pathname)
     1242  (map-file-to-ivector pathname '(unsigned-byte 8)))
     1243
     1244;;; Argument should be something returned by MAP-FILE-TO-OCTET-VECTOR;
     1245;;; this should be called at most once for any such object.
     1246(defun unmap-ivector (displaced-vector)
     1247  (let* ((v (array-data-and-offset displaced-vector))
     1248         (element-type (array-element-type displaced-vector)))
     1249    (if (or (eq v displaced-vector)
     1250            (not (with-lock-grabbed (*heap-ivector-lock*)
     1251                   (member v *heap-ivectors*))))
     1252      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-octet-vector))
     1253    (adjust-array displaced-vector '(0) :element-type element-type
     1254                  :displaced-to (make-array 0 :element-type element-type))
     1255    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
     1256           (file-length (- (length v) target::node-size))
     1257           (base-address (%inc-ptr pv (- (- *host-page-size* (- (* 2 target::node-size) target::fulltag-misc)))))
     1258           (fd (pref base-address :int)))
     1259      (with-lock-grabbed (*heap-ivector-lock*)
     1260        (setq *heap-ivectors* (delete v *heap-ivectors*)))
     1261      (#_munmap base-address (+ file-length *host-page-size*))
     1262      (fd-close fd)
     1263      t)))
     1264
     1265(defun unmap-octet-vector (v)
     1266  (unmap-ivector v))
     1267
     1268             
     1269                                               
     1270                       
     1271               
Note: See TracChangeset for help on using the changeset viewer.