cs: fix ptr-ref
on result of ptr-add
Fix `ptr-ref` to properly handle the offset in a pointer for specialized references, like extracting ` _double`. Thanks to Laurent Orseau for the bug report and Jens Axel Søgaard for intial debugging.
This commit is contained in:
parent
e301d3061d
commit
b0e65199fd
|
@ -1163,118 +1163,129 @@
|
|||
;; ----------------------------------------
|
||||
;; Test JIT inlining
|
||||
|
||||
(define bstr (cast (make-bytes 64) _pointer _pointer))
|
||||
(define (test-ptr-jit-inline bstr)
|
||||
(for/fold ([v 1.0]) ([i (in-range 100)])
|
||||
(ptr-set! bstr _float v)
|
||||
(ptr-set! bstr _float 1 (+ v 0.5))
|
||||
(ptr-set! bstr _float 'abs 8 (+ v 0.25))
|
||||
(unless (= v (ptr-ref bstr _float))
|
||||
(error 'float "failed"))
|
||||
(unless (= (+ v 0.5) (ptr-ref bstr _float 'abs 4))
|
||||
(error 'float "failed(2) ~s ~s" (+ v 0.5) (ptr-ref bstr _float 'abs 4)))
|
||||
(unless (= (+ v 0.25) (ptr-ref bstr _float 2))
|
||||
(error 'float "failed(3)"))
|
||||
(+ 1.0 v))
|
||||
|
||||
(for/fold ([v 1.0]) ([i (in-range 100)])
|
||||
(ptr-set! bstr _float v)
|
||||
(ptr-set! bstr _float 1 (+ v 0.5))
|
||||
(ptr-set! bstr _float 'abs 8 (+ v 0.25))
|
||||
(unless (= v (ptr-ref bstr _float))
|
||||
(error 'float "failed"))
|
||||
(unless (= (+ v 0.5) (ptr-ref bstr _float 'abs 4))
|
||||
(error 'float "failed(2) ~s ~s" (+ v 0.5) (ptr-ref bstr _float 'abs 4)))
|
||||
(unless (= (+ v 0.25) (ptr-ref bstr _float 2))
|
||||
(error 'float "failed(3)"))
|
||||
(+ 1.0 v))
|
||||
(for/fold ([v 1.0]) ([i (in-range 100)])
|
||||
(ptr-set! bstr _double v)
|
||||
(ptr-set! bstr _double 1 (+ v 0.5))
|
||||
(ptr-set! bstr _double 'abs 16 (+ v 0.25))
|
||||
(ptr-set! (ptr-add bstr 24) _double (+ v 0.125))
|
||||
(unless (= v (ptr-ref bstr _double))
|
||||
(error 'double "failed"))
|
||||
(unless (= (+ v 0.5) (ptr-ref bstr _double 'abs 8))
|
||||
(error 'double "failed(2)"))
|
||||
(unless (= (+ v 0.25) (ptr-ref bstr _double 2))
|
||||
(error 'double "failed(3)"))
|
||||
(unless (= (+ v 0.5) (ptr-ref (ptr-add bstr 8) _double))
|
||||
(error 'double "failed(4)"))
|
||||
(unless (= (+ v 0.125) (ptr-ref (ptr-add bstr 24) _double))
|
||||
(error 'double "failed(5)"))
|
||||
(+ 1.0 v))
|
||||
|
||||
(for/fold ([v 1.0]) ([i (in-range 100)])
|
||||
(ptr-set! bstr _double v)
|
||||
(ptr-set! bstr _double 1 (+ v 0.5))
|
||||
(ptr-set! bstr _double 'abs 16 (+ v 0.25))
|
||||
(unless (= v (ptr-ref bstr _double))
|
||||
(error 'double "failed"))
|
||||
(unless (= (+ v 0.5) (ptr-ref bstr _double 'abs 8))
|
||||
(error 'double "failed(2)"))
|
||||
(unless (= (+ v 0.25) (ptr-ref bstr _double 2))
|
||||
(error 'double "failed(3)"))
|
||||
(+ 1.0 v))
|
||||
(for ([i (in-range 256)])
|
||||
(ptr-set! bstr _uint8 i)
|
||||
(ptr-set! bstr _uint8 1 (- 255 i))
|
||||
(unless (= i (ptr-ref bstr _uint8))
|
||||
(error 'uint8 "fail ~s vs. ~s" i (ptr-ref bstr _uint8)))
|
||||
(unless (= (- 255 i) (ptr-ref bstr _uint8 'abs 1))
|
||||
(error 'uint8 "fail(2) ~s vs. ~s" (- 255 i) (ptr-ref bstr _uint8 'abs 1))))
|
||||
|
||||
(for ([i (in-range 256)])
|
||||
(ptr-set! bstr _uint8 i)
|
||||
(ptr-set! bstr _uint8 1 (- 255 i))
|
||||
(unless (= i (ptr-ref bstr _uint8))
|
||||
(error 'uint8 "fail ~s vs. ~s" i (ptr-ref bstr _uint8)))
|
||||
(unless (= (- 255 i) (ptr-ref bstr _uint8 'abs 1))
|
||||
(error 'uint8 "fail(2) ~s vs. ~s" (- 255 i) (ptr-ref bstr _uint8 'abs 1))))
|
||||
(for ([i (in-range -128 128)])
|
||||
(ptr-set! bstr _int8 i)
|
||||
(unless (= i (ptr-ref bstr _int8))
|
||||
(error 'int8 "fail ~s vs. ~s" i (ptr-ref bstr _int8))))
|
||||
|
||||
(for ([i (in-range -128 128)])
|
||||
(ptr-set! bstr _int8 i)
|
||||
(unless (= i (ptr-ref bstr _int8))
|
||||
(error 'int8 "fail ~s vs. ~s" i (ptr-ref bstr _int8))))
|
||||
(for ([i (in-range (expt 2 16))])
|
||||
(ptr-set! bstr _uint16 i)
|
||||
(ptr-set! bstr _uint16 3 (- (sub1 (expt 2 16)) i))
|
||||
(unless (= i (ptr-ref bstr _uint16))
|
||||
(error 'uint16 "fail ~s vs. ~s" i (ptr-ref bstr _uint16)))
|
||||
(unless (= (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))
|
||||
(error 'uint16 "fail(2) ~s vs. ~s" (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))))
|
||||
|
||||
(for ([i (in-range (expt 2 16))])
|
||||
(ptr-set! bstr _uint16 i)
|
||||
(ptr-set! bstr _uint16 3 (- (sub1 (expt 2 16)) i))
|
||||
(unless (= i (ptr-ref bstr _uint16))
|
||||
(error 'uint16 "fail ~s vs. ~s" i (ptr-ref bstr _uint16)))
|
||||
(unless (= (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))
|
||||
(error 'uint16 "fail(2) ~s vs. ~s" (- (sub1 (expt 2 16)) i) (ptr-ref bstr _uint16 'abs 6))))
|
||||
(for ([j (in-range 100)])
|
||||
(for ([i (in-range (- (expt 2 15)) (sub1 (expt 2 15)))])
|
||||
(ptr-set! bstr _int16 i)
|
||||
(unless (= i (ptr-ref bstr _int16))
|
||||
(error 'int16 "fail ~s vs. ~s" i (ptr-ref bstr _int16)))))
|
||||
|
||||
(for ([j (in-range 100)])
|
||||
(for ([i (in-range (- (expt 2 15)) (sub1 (expt 2 15)))])
|
||||
(ptr-set! bstr _int16 i)
|
||||
(unless (= i (ptr-ref bstr _int16))
|
||||
(error 'int16 "fail ~s vs. ~s" i (ptr-ref bstr _int16)))))
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _uint32 i)
|
||||
(ptr-set! bstr _uint32 1 (- hi (- i lo) 1))
|
||||
(unless (= i (ptr-ref bstr _uint32))
|
||||
(error 'uint32 "fail ~s vs. ~s" i (ptr-ref bstr _uint32)))
|
||||
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint32 'abs 4))
|
||||
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint32)))))
|
||||
(go 0 256)
|
||||
(go (- (expt 2 31) 256) (+ (expt 2 31) 256))
|
||||
(go (- (expt 2 32) 256) (expt 2 32)))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _int32 i)
|
||||
(unless (= i (ptr-ref bstr _int32))
|
||||
(error 'int32 "fail ~s vs. ~s" i (ptr-ref bstr _int32)))))
|
||||
(go -256 256)
|
||||
(go (- (expt 2 31) 256) (sub1 (expt 2 31)))
|
||||
(go (- (expt 2 31)) (- 256 (expt 2 31))))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _uint64 i)
|
||||
(ptr-set! bstr _uint64 1 (- hi (- i lo) 1))
|
||||
(unless (= i (ptr-ref bstr _uint64))
|
||||
(error 'uint64 "fail ~s vs. ~s" i (ptr-ref bstr _uint64)))
|
||||
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint64 'abs 8))
|
||||
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint64)))))
|
||||
(go 0 256)
|
||||
(go (- (expt 2 63) 256) (+ (expt 2 63) 256))
|
||||
(go (- (expt 2 64) 256) (expt 2 64)))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _int64 i)
|
||||
(unless (= i (ptr-ref bstr _int64))
|
||||
(error 'int64 "fail ~s vs. ~s" i (ptr-ref bstr _int64)))))
|
||||
(go -256 256)
|
||||
(go (- (expt 2 63) 256) (sub1 (expt 2 63)))
|
||||
(go (- (expt 2 63)) (- 256 (expt 2 63))))
|
||||
|
||||
(let ()
|
||||
(define p (cast bstr _pointer _pointer))
|
||||
(for ([i (in-range 100)])
|
||||
(ptr-set! bstr _pointer (ptr-add p i))
|
||||
(ptr-set! bstr _pointer 2 p)
|
||||
(unless (ptr-equal? p (ptr-add (ptr-ref bstr _pointer) (- i)))
|
||||
(error 'pointer "fail ~s vs. ~s"
|
||||
(cast p _pointer _intptr)
|
||||
(cast (ptr-ref bstr _pointer) _pointer _intptr)))
|
||||
(unless (ptr-equal? p (ptr-ref bstr _pointer 'abs (* 2 (ctype-sizeof _pointer))))
|
||||
(error 'pointer "fail ~s vs. ~s"
|
||||
(cast p _pointer _intptr)
|
||||
(cast (ptr-ref bstr _pointer 'abs (ctype-sizeof _pointer)) _pointer _intptr))))))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _uint32 i)
|
||||
(ptr-set! bstr _uint32 1 (- hi (- i lo) 1))
|
||||
(unless (= i (ptr-ref bstr _uint32))
|
||||
(error 'uint32 "fail ~s vs. ~s" i (ptr-ref bstr _uint32)))
|
||||
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint32 'abs 4))
|
||||
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint32)))))
|
||||
(go 0 256)
|
||||
(go (- (expt 2 31) 256) (+ (expt 2 31) 256))
|
||||
(go (- (expt 2 32) 256) (expt 2 32)))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _int32 i)
|
||||
(unless (= i (ptr-ref bstr _int32))
|
||||
(error 'int32 "fail ~s vs. ~s" i (ptr-ref bstr _int32)))))
|
||||
(go -256 256)
|
||||
(go (- (expt 2 31) 256) (sub1 (expt 2 31)))
|
||||
(go (- (expt 2 31)) (- 256 (expt 2 31))))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _uint64 i)
|
||||
(ptr-set! bstr _uint64 1 (- hi (- i lo) 1))
|
||||
(unless (= i (ptr-ref bstr _uint64))
|
||||
(error 'uint64 "fail ~s vs. ~s" i (ptr-ref bstr _uint64)))
|
||||
(unless (= (- hi (- i lo) 1) (ptr-ref bstr _uint64 'abs 8))
|
||||
(error 'uint32 "fail ~s vs. ~s" (- hi (- i lo) 1) (ptr-ref bstr _uint64)))))
|
||||
(go 0 256)
|
||||
(go (- (expt 2 63) 256) (+ (expt 2 63) 256))
|
||||
(go (- (expt 2 64) 256) (expt 2 64)))
|
||||
|
||||
(let ()
|
||||
(define (go lo hi)
|
||||
(for ([i (in-range lo hi)])
|
||||
(ptr-set! bstr _int64 i)
|
||||
(unless (= i (ptr-ref bstr _int64))
|
||||
(error 'int64 "fail ~s vs. ~s" i (ptr-ref bstr _int64)))))
|
||||
(go -256 256)
|
||||
(go (- (expt 2 63) 256) (sub1 (expt 2 63)))
|
||||
(go (- (expt 2 63)) (- 256 (expt 2 63))))
|
||||
|
||||
(let ()
|
||||
(define p (cast bstr _pointer _pointer))
|
||||
(for ([i (in-range 100)])
|
||||
(ptr-set! bstr _pointer (ptr-add p i))
|
||||
(ptr-set! bstr _pointer 2 p)
|
||||
(unless (ptr-equal? p (ptr-add (ptr-ref bstr _pointer) (- i)))
|
||||
(error 'pointer "fail ~s vs. ~s"
|
||||
(cast p _pointer _intptr)
|
||||
(cast (ptr-ref bstr _pointer) _pointer _intptr)))
|
||||
(unless (ptr-equal? p (ptr-ref bstr _pointer 'abs (* 2 (ctype-sizeof _pointer))))
|
||||
(error 'pointer "fail ~s vs. ~s"
|
||||
(cast p _pointer _intptr)
|
||||
(cast (ptr-ref bstr _pointer 'abs (ctype-sizeof _pointer)) _pointer _intptr)))))
|
||||
(test-ptr-jit-inline (make-bytes 64))
|
||||
(test-ptr-jit-inline (cast (make-bytes 64) _pointer _pointer))
|
||||
(let ([p (malloc 'raw 64)])
|
||||
(test-ptr-jit-inline p)
|
||||
(free p)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
@ -969,12 +969,12 @@
|
|||
[(and simple-p
|
||||
(fixnum? offset)
|
||||
(or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1)))))
|
||||
(if (bytevector? simple-p)
|
||||
(bytes-ref simple-p (if abs? offset (fxsll offset type-bits)))
|
||||
(let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
|
||||
(if (cpointer+offset? p)
|
||||
(+ offset (cpointer+offset-offset p))
|
||||
offset))])
|
||||
(let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
|
||||
(if (cpointer+offset? p)
|
||||
(+ offset (cpointer+offset-offset p))
|
||||
offset))])
|
||||
(if (bytevector? simple-p)
|
||||
(bytes-ref simple-p offset)
|
||||
(foreign-ref 'foreign-type simple-p offset)))]
|
||||
[else
|
||||
(if abs?
|
||||
|
@ -993,12 +993,12 @@
|
|||
(fixnum? offset)
|
||||
(or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1))))
|
||||
(ok-v? v))
|
||||
(if (bytevector? simple-p)
|
||||
(bytes-set simple-p (if abs? offset (fxsll offset type-bits)) v)
|
||||
(let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
|
||||
(if (cpointer+offset? p)
|
||||
(+ offset (cpointer+offset-offset p))
|
||||
offset))])
|
||||
(let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
|
||||
(if (cpointer+offset? p)
|
||||
(+ offset (cpointer+offset-offset p))
|
||||
offset))])
|
||||
(if (bytevector? simple-p)
|
||||
(bytes-set simple-p offset v)
|
||||
(foreign-set! 'foreign-type simple-p offset v)))]
|
||||
[else
|
||||
(if abs?
|
||||
|
|
Loading…
Reference in New Issue
Block a user