suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix ptr-ref on result of ptr-add

Browse Source 
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:
Matthew Flatt 2020-05-10 07:00:08 -06:00
parent e301d3061d
commit b0e65199fd
2 changed files with 127 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -1163,8 +1163,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Test JIT inlining ;; 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)]) (for/fold ([v 1.0]) ([i (in-range 100)])
(ptr-set! bstr _float v) (ptr-set! bstr _float v)
(ptr-set! bstr _float 1 (+ v 0.5)) (ptr-set! bstr _float 1 (+ v 0.5))
@ -1181,12 +1180,17 @@
(ptr-set! bstr _double v) (ptr-set! bstr _double v)
(ptr-set! bstr _double 1 (+ v 0.5)) (ptr-set! bstr _double 1 (+ v 0.5))
(ptr-set! bstr _double 'abs 16 (+ v 0.25)) (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)) (unless (= v (ptr-ref bstr _double))
(error 'double "failed")) (error 'double "failed"))
(unless (= (+ v 0.5) (ptr-ref bstr _double 'abs 8)) (unless (= (+ v 0.5) (ptr-ref bstr _double 'abs 8))
(error 'double "failed(2)")) (error 'double "failed(2)"))
(unless (= (+ v 0.25) (ptr-ref bstr _double 2)) (unless (= (+ v 0.25) (ptr-ref bstr _double 2))
(error 'double "failed(3)")) (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)) (+ 1.0 v))
(for ([i (in-range 256)]) (for ([i (in-range 256)])
@ -1274,7 +1278,14 @@
(unless (ptr-equal? p (ptr-ref bstr _pointer 'abs (* 2 (ctype-sizeof _pointer)))) (unless (ptr-equal? p (ptr-ref bstr _pointer 'abs (* 2 (ctype-sizeof _pointer))))
(error 'pointer "fail ~s vs. ~s" (error 'pointer "fail ~s vs. ~s"
(cast p _pointer _intptr) (cast p _pointer _intptr)
(cast (ptr-ref bstr _pointer 'abs (ctype-sizeof _pointer)) _pointer _intptr))))) (cast (ptr-ref bstr _pointer 'abs (ctype-sizeof _pointer)) _pointer _intptr))))))
(let ()
(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)))
;; ---------------------------------------- ;; ----------------------------------------

8
racket/src/cs/rumble/foreign.ss
View File

@ -969,12 +969,12 @@
[(and simple-p [(and simple-p
(fixnum? offset) (fixnum? offset)
(or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1))))) (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))]) (let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
(if (cpointer+offset? p) (if (cpointer+offset? p)
(+ offset (cpointer+offset-offset p)) (+ offset (cpointer+offset-offset p))
offset))]) offset))])
(if (bytevector? simple-p)
(bytes-ref simple-p offset)
(foreign-ref 'foreign-type simple-p offset)))] (foreign-ref 'foreign-type simple-p offset)))]
[else [else
(if abs? (if abs?
@ -993,12 +993,12 @@
(fixnum? offset) (fixnum? offset)
(or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1)))) (or (not abs?) (fx= 0 (fxand offset (fx- (fxsll 1 type-bits) 1))))
(ok-v? v)) (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))]) (let ([offset (let ([offset (if abs? offset (fxsll offset type-bits))])
(if (cpointer+offset? p) (if (cpointer+offset? p)
(+ offset (cpointer+offset-offset p)) (+ offset (cpointer+offset-offset p))
offset))]) offset))])
(if (bytevector? simple-p)
(bytes-set simple-p offset v)
(foreign-set! 'foreign-type simple-p offset v)))] (foreign-set! 'foreign-type simple-p offset v)))]
[else [else
(if abs? (if abs?