Changeset 33432 in project for release/5


Ignore:
Timestamp:
06/17/16 16:08:29 (3 years ago)
Author:
sjamaan
Message:

object-evict: Specify a few imports in the new style. Get rid of "foreign-lambda" where we can just use allocate and free from chicken.memory.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/5/object-evict/trunk/object-evict.scm

    r33431 r33432  
    99                      object-unevict)
    1010
    11 (import scheme chicken foreign)
    12 
    13 (use srfi-69 (only (chicken memory) align-to-word))
     11  (import scheme srfi-12 srfi-69 (chicken fixnum)
     12          (only (chicken memory) align-to-word allocate free)
     13          ;; TODO: remove "chicken"!  optional should not be needed!
     14          (only chicken when unless void optional) )
    1415
    1516(define (object-evicted? x) (##core#inline "C_permanentp" x))
    1617
    1718(define (object-evict x . allocator)
    18   (let ([allocator
    19          (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
    20         [tab (make-hash-table eq?)] )
     19  (let ((allocator (if (pair? allocator) (car allocator) allocate) )
     20        (tab (make-hash-table eq?)) )
    2121    (##sys#check-closure allocator 'object-evict)
    22     (let evict ([x x])
    23       (cond [(not (##core#inline "C_blockp" x)) x ]
    24             [(hash-table-ref/default tab x #f) ]
    25             [else
    26              (let* ([n (##sys#size x)]
    27                     [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
    28                     [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    29                (when (symbol? x) (##sys#setislot y 0 (void)))
    30                (hash-table-set! tab x y)
    31                (unless (##core#inline "C_byteblockp" x)
    32                  (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
    33                      [(fx>= i n)]
    34                    ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
    35                    (##sys#setislot y i (evict (##sys#slot x i))) ) )
    36                y ) ] ) ) ) )
     22    (let evict ((x x))
     23      (cond ((not (##core#inline "C_blockp" x)) x )
     24            ((hash-table-ref/default tab x #f) )
     25            (else
     26             (let* ((n (##sys#size x))
     27                    (bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n)))
     28                    (y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))) )
     29               (when (symbol? x) (##sys#setislot y 0 (void)))
     30               (hash-table-set! tab x y)
     31               (unless (##core#inline "C_byteblockp" x)
     32                 (do ((i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)))
     33                     ((fx>= i n))
     34                   ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
     35                   (##sys#setislot y i (evict (##sys#slot x i))) ) )
     36               y ) ) ) ) ) )
    3737
    3838(define (object-evict-to-location x ptr . limit)
     
    7575
    7676(define (object-release x . releaser)
    77   (let ([free (if (pair? releaser)
    78                   (car releaser)
    79                   (foreign-lambda void "C_free" c-pointer) ) ]
    80         [released '() ] )
    81     (let release ([x x])
    82       (cond [(not (##core#inline "C_blockp" x)) x ]
    83             [(not (##core#inline "C_permanentp" x)) x ]
    84             [(memq x released) x ]
    85             [else
    86              (let ([n (##sys#size x)])
    87                (set! released (cons x released))
    88                (unless (##core#inline "C_byteblockp" x)
    89                  (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    90                      [(fx>= i n)]
    91                    (release (##sys#slot x i))) )
    92                (free
    93                 (##sys#address->pointer
    94                  (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
     77  (let ((free (if (pair? releaser) (car releaser) free ) )
     78        (released '() ) )
     79    (let release ((x x))
     80      (cond ((not (##core#inline "C_blockp" x)) x )
     81            ((not (##core#inline "C_permanentp" x)) x )
     82            ((memq x released) x )
     83            (else
     84             (let ((n (##sys#size x)))
     85               (set! released (cons x released))
     86               (unless (##core#inline "C_byteblockp" x)
     87                 (do ((i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)))
     88                     ((fx>= i n))
     89                   (release (##sys#slot x i))) )
     90               (free
     91                (##sys#address->pointer
     92                 (##core#inline_allocate ("C_block_address" 4) x))) ) ) ) ) ) )
    9593
    9694(define (object-size x)
Note: See TracChangeset for help on using the changeset viewer.