112 lines
4.6 KiB
Scheme
112 lines
4.6 KiB
Scheme
|
;;; layout.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
(define compute-field-offsets
|
||
|
|
; type-disp is the offset from the ptr to the object's true address
|
||
|
|
; ls is a list of field descriptors
|
||
|
|
(lambda (who type-disp ls)
|
||
|
|
(define parse-field
|
||
|
|
(lambda (f)
|
||
|
|
(define supported-type
|
||
|
|
(lambda (x)
|
||
|
|
(let ([x (filter-foreign-type x)])
|
||
|
|
(and (memq x (record-datatype list)) x))))
|
||
|
|
(define (err) ($oops who "invalid field specifier ~s" f))
|
||
|
|
(define (s0 f)
|
||
|
|
(cond
|
||
|
|
[(symbol? f) (values f #t 'scheme-object 'scheme-object 1)]
|
||
|
|
[(list? f) (s1 f)]
|
||
|
|
[else (err)]))
|
||
|
|
(define (s1 f)
|
||
|
|
(cond
|
||
|
|
[(null? f) (err)]
|
||
|
|
[(null? (cdr f))
|
||
|
|
(if (symbol? (car f))
|
||
|
|
(values (car f) #t 'scheme-object 'scheme-object 1)
|
||
|
|
(err))]
|
||
|
|
[(eq? (car f) 'immutable) (s2 (cdr f) #f)]
|
||
|
|
[(eq? (car f) 'mutable) (s2 (cdr f) #t)]
|
||
|
|
[else (s2 f #t)]))
|
||
|
|
(define (s2 f mutable?)
|
||
|
|
(cond
|
||
|
|
[(null? f) (err)]
|
||
|
|
[(null? (cdr f))
|
||
|
|
(if (symbol? (car f))
|
||
|
|
(values (car f) mutable? 'scheme-object 'scheme-object 1)
|
||
|
|
(err))]
|
||
|
|
[(supported-type (car f)) =>
|
||
|
|
(lambda (real-type) (s3 (cdr f) mutable? (car f) real-type))]
|
||
|
|
[else (s3 f mutable? 'scheme-object 'scheme-object)]))
|
||
|
|
(define (s3 f mutable? type real-type)
|
||
|
|
(cond
|
||
|
|
[(null? f) (err)]
|
||
|
|
[(symbol? (car f)) (s4 (cdr f) mutable? type real-type (car f))]
|
||
|
|
[else (err)]))
|
||
|
|
(define (s4 f mutable? type real-type name)
|
||
|
|
(cond
|
||
|
|
[(null? f) (values name mutable? type real-type 1)]
|
||
|
|
[(and (integer? (car f)) (nonnegative? (car f)))
|
||
|
|
(values name mutable? type real-type (car f))]
|
||
|
|
[else (err)]))
|
||
|
|
(s0 f)))
|
||
|
|
(define type->bytes
|
||
|
|
(lambda (ty)
|
||
|
|
(define-syntax ->bytes
|
||
|
|
(syntax-rules () ((_ type bytes pred) bytes)))
|
||
|
|
(record-datatype cases ty ->bytes
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
(define get-max-alignment
|
||
|
|
(lambda (ty)
|
||
|
|
(case ty
|
||
|
|
[(single-float double-float) (constant max-float-alignment)]
|
||
|
|
[else (constant max-integer-alignment)])))
|
||
|
|
(define align
|
||
|
|
(lambda (n bytes type)
|
||
|
|
(let ([k (gcd (get-max-alignment type) bytes)])
|
||
|
|
(logand (+ n (fx- k 1)) (fx- k)))))
|
||
|
|
(with-values
|
||
|
|
(let f ((ls ls) (byte 0))
|
||
|
|
(if (null? ls)
|
||
|
|
(values 0 0 '() byte) ; pm, mpm, flds, size
|
||
|
|
(with-values (parse-field (car ls))
|
||
|
|
(lambda (name mutable? type real-type len)
|
||
|
|
(let* ((bytes (type->bytes real-type))
|
||
|
|
; align even if len is zero to give element its
|
||
|
|
; proper alignment, since zero at the end can mean
|
||
|
|
; variable-length
|
||
|
|
(byte (align byte bytes real-type)))
|
||
|
|
(with-values (f (cdr ls) (+ byte (* bytes len)))
|
||
|
|
(lambda (pm mpm flds size)
|
||
|
|
(let ((flds (cons (make-fld name mutable? type (+ type-disp byte)) flds)))
|
||
|
|
(if (eq? real-type 'scheme-object)
|
||
|
|
(let ((m (ash (- (ash 1 len) 1)
|
||
|
|
(fxsrl byte (constant log2-ptr-bytes)))))
|
||
|
|
(values
|
||
|
|
(+ pm m)
|
||
|
|
(if mutable? (+ mpm m) mpm)
|
||
|
|
flds
|
||
|
|
size))
|
||
|
|
(values pm mpm flds size))))))))))
|
||
|
|
(lambda (pm mpm flds size)
|
||
|
|
(define sanitize-mask
|
||
|
|
; if bits are set for each word, return mask of -1
|
||
|
|
; to give gc a quick test for pure vs. impure
|
||
|
|
(lambda (m size)
|
||
|
|
(if (= (- (ash 1 (quotient (+ size -1 (constant ptr-bytes)) (constant ptr-bytes))) 1) m)
|
||
|
|
-1
|
||
|
|
m)))
|
||
|
|
(values (sanitize-mask pm size) mpm flds size)))))
|
||
|
|
|