Changeset 6431 for branches/x8664-call


Ignore:
Timestamp:
May 7, 2007, 6:58:55 AM (13 years ago)
Author:
gb
Message:

More file-mapping stuff.

File:
1 edited

Legend:

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

    r6417 r6431  
    12421242  (map-file-to-ivector pathname '(unsigned-byte 8)))
    12431243
    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))
     1244(defun mapped-vector-data-address-and-size (displaced-vector)
     1245  (let* ((v (array-displacement displaced-vector))
    12481246         (element-type (array-element-type displaced-vector)))
    12491247    (if (or (eq v displaced-vector)
    12501248            (not (with-lock-grabbed (*heap-ivector-lock*)
    12511249                   (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))
     1250      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
    12551251    (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)))
     1252           (ctype (specifier-type element-type))
     1253           (arch (backend-target-arch *target-backend*)))
     1254      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
     1255              (- (funcall (arch::target-array-data-size-function arch)
     1256                          (ctype-subtype ctype)
     1257                          (length v))
     1258                 target::node-size)))))
     1259
     1260 
     1261;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
     1262;;; this should be called at most once for any such object.
     1263(defun unmap-ivector (displaced-vector)
     1264  (multiple-value-bind (data-address size-in-octets)
     1265      (mapped-vector-data-address-and-size displaced-vector)
     1266  (let* ((v (array-displacement displaced-vector))
     1267         (base-address (%inc-ptr data-address (- *host-page-size*)))
     1268         (fd (pref base-address :int)))
    12591269      (with-lock-grabbed (*heap-ivector-lock*)
    12601270        (setq *heap-ivectors* (delete v *heap-ivectors*)))
    1261       (#_munmap base-address (+ file-length *host-page-size*))
     1271      (#_munmap base-address (+ size-in-octets *host-page-size*))
    12621272      (fd-close fd)
    12631273      t)))
     
    12661276  (unmap-ivector v))
    12671277
    1268              
     1278(defun lock-mapped-vector (v)
     1279  (multiple-value-bind (address nbytes)
     1280      (mapped-vector-data-address-and-size v)
     1281    (eql 0 (#_mlock address nbytes))))
     1282
     1283(defun unlock-mapped-vector (v)
     1284  (multiple-value-bind (address nbytes)
     1285      (mapped-vector-data-address-and-size v)
     1286    (eql 0 (#_munlock address nbytes))))
     1287
     1288(defun bitmap-for-mapped-range (address nbytes)
     1289  (let* ((npages (ceiling nbytes *host-page-size*)))
     1290    (%stack-block ((vec npages))
     1291      (when (eql 0 (#_mincore address nbytes vec))
     1292        (let* ((bits (make-array npages :element-type 'bit)))
     1293          (dotimes (i npages bits)
     1294            (setf (sbit bits i)
     1295                  (logand 1 (%get-unsigned-byte vec i)))))))))
     1296
     1297(defun percentage-of-resident-pages (address nbytes)
     1298  (let* ((npages (ceiling nbytes *host-page-size*)))
     1299    (%stack-block ((vec npages))
     1300      (when (eql 0 (#_mincore address nbytes vec))
     1301        (let* ((nresident 0))
     1302          (dotimes (i npages (* 100.0 (/ nresident npages)))
     1303            (when (logbitp 0 (%get-unsigned-byte vec i))
     1304              (incf nresident))))))))
     1305
     1306(defun mapped-vector-resident-pages (v)
     1307  (multiple-value-bind (address nbytes)
     1308      (mapped-vector-data-address-and-size v)
     1309    (bitmap-for-mapped-range address nbytes)))
     1310
     1311(defun mapped-vector-resident-pages-percentage (v)
     1312  (multiple-value-bind (address nbytes)
     1313      (mapped-vector-data-address-and-size v)
     1314    (percentage-of-resident-pages address nbytes)))
     1315 
     1316
    12691317                                               
    1270                        
    1271                
     1318                                     
Note: See TracChangeset for help on using the changeset viewer.