From 589f0e55e4ea61dc672aa8bc322597f80f0d2ad0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Apr 2021 09:34:18 -0600 Subject: [PATCH] ffi/unsafe: repair `cast` from GCable pointer with offset The repair in 601f4a76e7 did not correctly handle pointers with a non-zero offset. Thanks to Bruce O'Neel for the report. --- .../tests/racket/foreign-test.rktl | 22 +++++ racket/collects/ffi/unsafe.rkt | 99 ++++++++++++------- 2 files changed, 88 insertions(+), 33 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index da60ccefe2..6417424a04 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/pkgs/racket-test-core/tests/racket/foreign-test.rktl @@ -731,6 +731,15 @@ (test (cast p _thing-pointer _intptr) cast q _stuff-pointer _intptr)) +;; For casts where the BC output might share with the input, so +;; an offset pointer needs to be 'atomic-interior +(define (share-protect bstr) + (if (eq? 'racket (system-type 'vm)) + (let ([new-bstr (malloc 'atomic-interior (add1 (bytes-length bstr)))]) + (memcpy new-bstr bstr (add1 (bytes-length bstr))) + (make-sized-byte-string new-bstr (bytes-length bstr))) + bstr)) + ;; `cast` should auto-upgrade target pointer types using `_gcable` for a GCable argument (test #t cpointer-gcable? (cast #"x" _pointer _pointer)) (test #t cpointer-gcable? (cast #"x" _gcpointer _pointer)) @@ -738,9 +747,22 @@ (test #t cpointer-gcable? (cast (malloc 8) _pointer _pointer)) (test #t cpointer-gcable? (cast (malloc 8) _gcpointer _pointer)) (test #t cpointer-gcable? (cast (malloc 8) _pointer _gcpointer)) +(test #t cpointer-gcable? (cast (ptr-add (malloc 8) 5) _pointer _pointer)) (test #t cpointer-gcable? (cast #"x" _bytes _pointer)) (test #t cpointer-gcable? (cast #"x" _bytes _gcpointer)) (test #t cpointer-gcable? (cast #"x" _bytes _bytes)) +(test "lo" cast #"lo\0" _pointer _string/utf-8) +(test "lo" cast (if (system-big-endian?) #"l\0o\0\0\0" #"l\0o\0\0\0") _pointer _string/utf-16) +(test "lo" cast (if (system-big-endian?) #"\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"l\0\0\0o\0\0\0\0\0\0\0") + _pointer _string/ucs-4) +(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _bytes)) +(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _pointer)) +(test (char->integer #\y) ptr-ref (cast (ptr-add #"xy" 1) _pointer _pointer) _byte) +(test #"lo" cast (ptr-add (share-protect #"hello\0") 3) _pointer _bytes) +(test "lo" cast (ptr-add #"hello\0" 3) _pointer _string/utf-8) +(test "lo" cast (ptr-add (if (system-big-endian?) #"e\0l\0l\0o\0\0\0" #"\0l\0l\0o\0\0\0") 3) _pointer _string/utf-16) +(test "lo" cast (ptr-add (share-protect (if (system-big-endian?) #"\0\0\0l\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"\0\0\0\0l\0\0\0o\0\0\0\0\0\0\0")) 4) + _pointer _string/ucs-4) (test #t 'many-casts (for/and ([i (in-range 1000)]) diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 22263c8a89..3b206ec178 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -1476,46 +1476,79 @@ (cond [(and (cpointer? p) (cpointer-gcable? p)) + (define to-ct (ctype-coretype to-type)) + (define (pointer->gcpointer t) + (define ct (ctype-coretype t)) + (if (eq? ct 'pointer) + (_gcable t) + t)) (let loop ([p p]) (cond - [(and (not (zero? (ptr-offset p))) - (let ([ct (ctype-coretype to-type)]) - (or (eq? ct 'pointer) - (eq? ct 'gcpointer)))) - (define o (ptr-offset p)) - (define from-t (cpointer-tag p)) - (define z (ptr-add p (- o))) - (when from-t - (set-cpointer-tag! z from-t)) - (define q (loop z)) - (define to-t (cpointer-tag q)) - (define r (ptr-add q o)) - (when to-t - (set-cpointer-tag! r to-t)) - r] - [(ctype-pointer? to-type) - (define (pointer->cpointer t) - (define ct (ctype-coretype t)) - (if (eq? ct 'pointer) - (_gcable t) - t)) - (convert p (pointer->cpointer from-type) (pointer->cpointer to-type))] + [(coretype-pointer? to-ct) + (cond + [(not (zero? (ptr-offset p))) + (cond + [(coretype-plain-pointer? to-ct) + (define o (ptr-offset p)) + (define from-t (cpointer-tag p)) + (define z (ptr-add p (- o))) + (when from-t + (set-cpointer-tag! z from-t)) + (define q (loop z)) + (define to-t (cpointer-tag q)) + (define r (ptr-add q o)) + (when to-t + (set-cpointer-tag! r to-t)) + r] + [(coretype-noncopying? to-ct) + ;; we assume that an interior pointer is ok/wanted + (convert p (pointer->gcpointer from-type) to-type)] + [else + ;; converting to a string or similar; + ;; we can't store an offset pointer into + ;; GCable memory, so copy to fresh GCable + ;; memory, first + (define nul-count (case to-ct + [(string/ucs-4) 4] + [(string/utf-16) 2] + [else 1])) + (define len (let loop ([i 0] [count nul-count]) + (if (zero? (ptr-ref p _byte i)) + (if (= count 1) + (+ i nul-count) + (loop (add1 i) (sub1 count))) + (loop (add1 i) nul-count)))) + (define p2 (malloc len 'atomic)) + (memcpy p2 p len) + (loop p2)])] + [else + (convert p (pointer->gcpointer from-type) (pointer->gcpointer to-type))])] [else (convert p from-type to-type)]))] [else (convert p from-type to-type)])) -(define (ctype-pointer? ctype) - (define coretype (ctype-coretype ctype)) - (memq coretype '(pointer - gcpointer - fpointer - bytes - scheme - string - string/ucs-4 - string/utf-16 - symbol))) +(define (coretype-pointer? ct) + (memq ct '(pointer + gcpointer + fpointer + bytes + scheme + string + string/ucs-4 + string/utf-16 + symbol))) + +(define (coretype-plain-pointer? ct) + (or (eq? ct 'pointer) + (eq? ct 'gcpointer) + (eq? ct 'fpointer))) + +(define (coretype-noncopying? ct) + (or (and (eq? 'racket (system-type 'vm)) + (or (eq? ct 'bytes) + (eq? ct 'string/ucs-4))) + (eq? ct 'scheme))) (define* (_or-null ctype) (let ([coretype (ctype-coretype ctype)])