1#lang racket/base 2(require '#%flfxnum 3 (only-in '#%foreign cpointer? ptr-add) 4 (only-in '#%place place-shared?) 5 racket/prefab) 6 7(provide place-message-allowed? 8 place-message-allowed-direct? 9 10 message-ize 11 un-message-ize 12 13 prop:place-message) 14 15;; A prop:place-message value is a procedure that takes self 16;; and returns either #f [=> not a place message after all] or 17;; (-> (-> v)) 18(define-values (prop:place-message place-message? place-message-ref) 19 (make-struct-type-property 'place-message)) 20 21(struct message-ized (unmessage) 22 #:authentic) 23 24(define (allowed? v #:direct? direct?) 25 (let loop ([v v] [graph #hasheq()]) 26 (or (number? v) 27 (char? v) 28 (boolean? v) 29 (keyword? v) 30 (void? v) 31 (symbol? v) 32 (and (or (string? v) 33 (bytes? v)) 34 (or (not direct?) 35 (immutable? v) 36 (and (bytes? v) 37 (place-shared? v)))) 38 (null? v) 39 (and (pair? v) 40 (or (hash-ref graph v #f) 41 (let ([graph (hash-set graph v #t)]) 42 (and (loop (car v) graph) 43 (loop (cdr v) graph))))) 44 (and (vector? v) 45 (or (not direct?) 46 (and (immutable? v) 47 (not (impersonator? v)))) 48 (or (hash-ref graph v #f) 49 (let ([graph (hash-set graph v #t)]) 50 (for/and ([e (in-vector v)]) 51 (loop e graph))))) 52 (and (immutable-prefab-struct-key v) 53 (or (hash-ref graph v #f) 54 (let ([graph (hash-set graph v #t)]) 55 (for/and ([e (in-vector (struct->vector v))]) 56 (loop e graph))))) 57 (and (hash? v) 58 (or (not direct?) 59 (and (immutable? v) 60 (not (impersonator? v)))) 61 (or (hash-ref graph v #f) 62 (let ([graph (hash-set graph v #t)]) 63 (for/and ([(k v) (in-hash v)]) 64 (and (loop k graph) 65 (loop v graph)))))) 66 (and (not direct?) 67 (or (cpointer? v) 68 (and (or (fxvector? v) 69 (flvector? v) 70 (bytes? v)) 71 (place-shared? v)) 72 (and (place-message? v) 73 ((place-message-ref v) v) 74 #t)))))) 75 76(define (place-message-allowed-direct? v) 77 (allowed? v #:direct? #t)) 78 79(define (place-message-allowed? v) 80 (allowed? v #:direct? #f)) 81 82;; Convert a message to a form suitable to keep in a channel, but 83;; simultaneously check whether the message is ok, since a message 84;; might start out with mutable elements that are changed while 85;; the conversion is in progress (but we convert enough to avoid 86;; problems afterward) 87(define (message-ize v fail) 88 (define graph #f) 89 (define used #f) 90 (define (maybe-ph ph v new-v) 91 (cond 92 [(and used (hash-ref used ph #f)) 93 (placeholder-set! ph new-v) 94 ph] 95 [else 96 (hash-remove! graph v) 97 new-v])) 98 (define new-v 99 (let loop ([v v]) 100 (cond 101 [(or (number? v) 102 (char? v) 103 (boolean? v) 104 (keyword? v) 105 (void? v) 106 (symbol? v) 107 (null? v)) 108 v] 109 [(string? v) 110 (string->immutable-string v)] 111 [(bytes? v) 112 (if (place-shared? v) 113 v 114 (bytes->immutable-bytes v))] 115 [else 116 (unless graph (set! graph (make-hasheq))) 117 (cond 118 [(hash-ref graph v #f) 119 => (lambda (v) 120 (unless used (set! used (make-hasheq))) 121 (hash-set! used v #t) 122 v)] 123 [(pair? v) 124 (define ph (make-placeholder #f)) 125 (hash-set! graph v ph) 126 (maybe-ph ph v (cons (loop (car v)) 127 (loop (cdr v))))] 128 [(vector? v) 129 (define ph (make-placeholder #f)) 130 (hash-set! graph v ph) 131 (maybe-ph ph v (for/vector #:length (vector-length v) ([e (in-vector v)]) 132 (loop e)))] 133 [(immutable-prefab-struct-key v) 134 => (lambda (k) 135 (define ph (make-placeholder #f)) 136 (hash-set! graph v ph) 137 (maybe-ph 138 ph 139 v 140 (apply make-prefab-struct 141 k 142 (for/list ([e (in-vector (struct->vector v) 1)]) 143 (loop e)))))] 144 [(hash? v) 145 (define ph (make-placeholder #f)) 146 (hash-set! graph v ph) 147 (maybe-ph 148 ph 149 v 150 (cond 151 [(hash-eq? v) 152 (for/hasheq ([(k v) (in-hash v)]) 153 (values (loop k) (loop v)))] 154 [(hash-eqv? v) 155 (for/hasheqv ([(k v) (in-hash v)]) 156 (values (loop k) (loop v)))] 157 [else 158 (for/hash ([(k v) (in-hash v)]) 159 (values (loop k) (loop v)))]))] 160 [(cpointer? v) 161 (ptr-add v 0)] 162 [(and (or (fxvector? v) 163 (flvector? v)) 164 (place-shared? v)) 165 v] 166 [(place-message? v) 167 (define make-unmessager ((place-message-ref v) v)) 168 (if make-unmessager 169 (message-ized (make-unmessager)) 170 (fail))] 171 [else (fail)])]))) 172 (message-ized new-v)) 173 174(define (un-message-ize v) 175 (if (message-ized? v) 176 (make-reader-graph (do-un-message-ize (message-ized-unmessage v))) 177 v)) 178 179(define (do-un-message-ize v) 180 (define graph #f) 181 (let loop ([v v]) 182 (cond 183 [(placeholder? v) 184 (define ph (make-placeholder #f)) 185 (unless graph (set! graph (make-hasheq))) 186 (cond 187 [(hash-ref graph v #f) => (lambda (ph) ph)] 188 [else 189 (hash-set! graph v ph) 190 (placeholder-set! ph (loop (placeholder-get v))) 191 ph])] 192 [(pair? v) 193 (cons (loop (car v)) (loop (cdr v)))] 194 [(vector? v) 195 (vector->immutable-vector 196 (for/vector #:length (vector-length v) ([e (in-vector v)]) 197 (loop e)))] 198 [(immutable-prefab-struct-key v) 199 => (lambda (k) 200 (apply make-prefab-struct 201 k 202 (for/list ([e (in-vector (struct->vector v) 1)]) 203 (loop e))))] 204 [(hash? v) 205 (cond 206 [(hash-eq? v) 207 (for/hasheq ([(k v) (in-hash v)]) 208 (values (loop k) (loop v)))] 209 [(hash-eqv? v) 210 (for/hasheqv ([(k v) (in-hash v)]) 211 (values (loop k) (loop v)))] 212 [else 213 (for/hash ([(k v) (in-hash v)]) 214 (values (loop k) (loop v)))])] 215 [(and (cpointer? v) 216 v ; not #f 217 (not (bytes? v))) 218 (ptr-add v 0)] 219 [(message-ized? v) 220 ((message-ized-unmessage v))] 221 [else v]))) 222 223(module+ test 224 (define-syntax-rule (test expect actual) 225 (let ([v actual]) 226 (unless (equal? expect v) 227 (error 'test "failed: ~s = ~s" 'actual v)))) 228 229 (struct external (a) 230 #:property prop:place-message (lambda (self) 231 (lambda () 232 (define a (external-a self)) 233 (lambda () (external a))))) 234 235 (test #t (place-message-allowed? "apple")) 236 (test #t (place-message-allowed-direct? "apple")) 237 (test #f (place-message-allowed-direct? (string-copy "apple"))) 238 (test #f (place-message-allowed-direct? (cons 1 (string-copy "apple")))) 239 240 (test #t (place-message-allowed-direct? '(a . b))) 241 (test #t (place-message-allowed-direct? '#(a b))) 242 (test #t (place-message-allowed-direct? '#hasheq((a . b)))) 243 (test #t (place-message-allowed-direct? '#s(pre 1 2 3))) 244 245 (define direct-cyclic (read (open-input-string "#0=(1 #0# 2)"))) 246 (test #t (place-message-allowed-direct? direct-cyclic)) 247 248 (define stateful-cyclic (make-reader-graph 249 (let ([ph (make-placeholder #f)] 250 [ph2 (make-placeholder #f)] 251 [ph3 (make-placeholder #f)]) 252 (define (as ph v) (placeholder-set! ph v) v) 253 (as ph2 (vector (as ph (cons ph (string-copy "apple"))) 254 ph2 255 (as ph3 (hasheq 'a 1 'b ph3)) 256 '#s(pre 4 5))) 257 ph))) 258 (test #f (place-message-allowed-direct? stateful-cyclic)) 259 (test #t (place-message-allowed? stateful-cyclic)) 260 (test stateful-cyclic (un-message-ize (message-ize stateful-cyclic))) 261 262 (define ext (external 'x)) 263 (test #t (place-message-allowed? ext)) 264 (test #f (place-message-allowed-direct? ext)) 265 (define ext2 (un-message-ize (message-ize ext))) 266 (test #t (external? ext2)) 267 (test #f (eq? ext ext2)) 268 (test 'x (external-a ext2)) 269 270 (void)) 271