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