Changeset 6496


Ignore:
Timestamp:
May 9, 2007, 8:27:43 AM (15 years ago)
Author:
gb
Message:

File-mapped vectors.

File:
1 edited

Legend:

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

    r6200 r6496  
    11281128             1)
    11291129            #+freebsd-target
    1130             (%stack-block ((ret (record-length :uint))
    1131                            (mib (* (record-length :uint))))
    1132               (setf (%get-unsigned-long mib 0)
     1130            (rlet ((ret :uint))
     1131              (%stack-block ((mib (* (record-length :uint) 2)))
     1132              (setf (paref mib (:array :uint) 0)
    11331133                    #$CTL_HW
    1134                     (%get-unsigned-long mib (record-length :uint))
     1134                    (paref mib (:array :uint) 1)
    11351135                    #$HW_NCPU)
    11361136              (rlet ((oldsize :uint (record-length :uint)))
    11371137                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
    11381138                  (pref ret :uint)
    1139                   1)))
     1139                  1))))
    11401140            )))
    11411141
    11421142(def-load-pointers spin-count ()
    11431143  (if (eql 1 (cpu-count))
    1144     (setq *spin-lock-tries* 1)
    1145     (setq *spin-lock-tries* 1024)))
     1144    (%defglobal '*spin-lock-tries* 1)
     1145    (%defglobal '*spin-lock-tries* 1024)))
    11461146
    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
     1173                   (ndata-elements
     1174                    (ash len
     1175                         (ecase bits-per-element
     1176                           (1 3)
     1177                           (8 0)
     1178                           (16 -1)
     1179                           (32 -2)
     1180                           (64 -3))))
     1181                   (nalignment-elements
     1182                    (ash target::nbits-in-word
     1183                         (ecase bits-per-element
     1184                           (1 0)
     1185                           (8 -3)
     1186                           (16 -4)
     1187                           (32 -5)
     1188                           (64 -6)))))
     1189              (if (>= (+ ndata-elements nalignment-elements)
     1190                      array-total-size-limit)
     1191                (progn
     1192                  (fd-close fd)
     1193                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
     1194                (let* ((addr (#_mmap +null-ptr+
     1195                                     nbytes
     1196                                     #$PROT_NONE
     1197                                     (logior #$MAP_ANON #$MAP_PRIVATE)
     1198                                     -1
     1199                                     0)))             
     1200                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
     1201                    (let* ((errno (%get-errno)))
     1202                      (fd-close fd)
     1203                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
     1204              ;;; Remap the first page so that we can put a vector header
     1205              ;;; there; use the first word on the first page to remember
     1206              ;;; the file descriptor.
     1207                    (progn
     1208                      (#_mmap addr
     1209                              *host-page-size*
     1210                              (logior #$PROT_READ #$PROT_WRITE)
     1211                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
     1212                              -1
     1213                              0)
     1214                      (setf (pref addr :int) fd)
     1215                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
     1216                                                            (* 2 target::node-size)))))
     1217                        (setf (pref header-addr :unsigned-long)
     1218                              (logior (element-type-subtype upgraded-type)
     1219                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
     1220                        (when (> len 0)
     1221                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
     1222                            (unless (eql target-addr
     1223                                         (#_mmap target-addr
     1224                                                 len
     1225                                                 #$PROT_READ
     1226                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
     1227                                                 fd
     1228                                                 0))
     1229                              (let* ((errno (%get-errno)))
     1230                                (fd-close fd)
     1231                                (#_munmap addr nbytes)
     1232                                (error "Mapping failed: ~a" (%strerror errno))))))
     1233                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
     1234                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
     1235                            ;; Tell some parts of OpenMCL - notably the
     1236                            ;; printer - that this thing off in foreign
     1237                            ;; memory is a real lisp object and not
     1238                            ;; "bogus".
     1239                            (with-lock-grabbed (*heap-ivector-lock*)
     1240                              (push vector *heap-ivectors*))
     1241                            (make-array ndata-elements
     1242                                        :element-type upgraded-type
     1243                                        :displaced-to vector
     1244                                        :adjustable t
     1245                                        :displaced-index-offset nalignment-elements)))))))))))))))
     1246
     1247(defun map-file-to-octet-vector (pathname)
     1248  (map-file-to-ivector pathname '(unsigned-byte 8)))
     1249
     1250(defun mapped-vector-data-address-and-size (displaced-vector)
     1251  (let* ((v (array-displacement displaced-vector))
     1252         (element-type (array-element-type displaced-vector)))
     1253    (if (or (eq v displaced-vector)
     1254            (not (with-lock-grabbed (*heap-ivector-lock*)
     1255                   (member v *heap-ivectors*))))
     1256      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
     1257    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
     1258           (ctype (specifier-type element-type))
     1259           (arch (backend-target-arch *target-backend*)))
     1260      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
     1261              (- (funcall (arch::target-array-data-size-function arch)
     1262                          (ctype-subtype ctype)
     1263                          (length v))
     1264                 target::node-size)))))
     1265
     1266 
     1267;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
     1268;;; this should be called at most once for any such object.
     1269(defun unmap-ivector (displaced-vector)
     1270  (multiple-value-bind (data-address size-in-octets)
     1271      (mapped-vector-data-address-and-size displaced-vector)
     1272  (let* ((v (array-displacement displaced-vector))
     1273         (base-address (%inc-ptr data-address (- *host-page-size*)))
     1274         (fd (pref base-address :int)))
     1275      (let* ((element-type (array-element-type displaced-vector)))
     1276        (adjust-array displaced-vector 0
     1277                      :element-type element-type
     1278                      :displaced-to (make-array 0 :element-type element-type)
     1279                      :displaced-index-offset 0))
     1280      (with-lock-grabbed (*heap-ivector-lock*)
     1281        (setq *heap-ivectors* (delete v *heap-ivectors*)))
     1282      (#_munmap base-address (+ size-in-octets *host-page-size*))     
     1283      (fd-close fd)
     1284      t)))
     1285
     1286(defun unmap-octet-vector (v)
     1287  (unmap-ivector v))
     1288
     1289(defun lock-mapped-vector (v)
     1290  (multiple-value-bind (address nbytes)
     1291      (mapped-vector-data-address-and-size v)
     1292    (eql 0 (#_mlock address nbytes))))
     1293
     1294(defun unlock-mapped-vector (v)
     1295  (multiple-value-bind (address nbytes)
     1296      (mapped-vector-data-address-and-size v)
     1297    (eql 0 (#_munlock address nbytes))))
     1298
     1299(defun bitmap-for-mapped-range (address nbytes)
     1300  (let* ((npages (ceiling nbytes *host-page-size*)))
     1301    (%stack-block ((vec npages))
     1302      (when (eql 0 (#_mincore address nbytes vec))
     1303        (let* ((bits (make-array npages :element-type 'bit)))
     1304          (dotimes (i npages bits)
     1305            (setf (sbit bits i)
     1306                  (logand 1 (%get-unsigned-byte vec i)))))))))
     1307
     1308(defun percentage-of-resident-pages (address nbytes)
     1309  (let* ((npages (ceiling nbytes *host-page-size*)))
     1310    (%stack-block ((vec npages))
     1311      (when (eql 0 (#_mincore address nbytes vec))
     1312        (let* ((nresident 0))
     1313          (dotimes (i npages (* 100.0 (/ nresident npages)))
     1314            (when (logbitp 0 (%get-unsigned-byte vec i))
     1315              (incf nresident))))))))
     1316
     1317(defun mapped-vector-resident-pages (v)
     1318  (multiple-value-bind (address nbytes)
     1319      (mapped-vector-data-address-and-size v)
     1320    (bitmap-for-mapped-range address nbytes)))
     1321
     1322(defun mapped-vector-resident-pages-percentage (v)
     1323  (multiple-value-bind (address nbytes)
     1324      (mapped-vector-data-address-and-size v)
     1325    (percentage-of-resident-pages address nbytes)))
     1326 
Note: See TracChangeset for help on using the changeset viewer.