pure-function.rkt (19106B)
1 #lang typed/racket/base 2 3 (require "immutable-struct-constructor.rkt" 4 "pure-exception.rkt" 5 racket/set 6 racket/format 7 racket/promise 8 (only-in typed/racket/unsafe unsafe-require/typed) 9 (prefix-in te: type-expander) 10 phc-toolkit 11 version-case 12 (for-syntax (rename-in racket/base [... …]) 13 racket/match 14 syntax/modcollapse 15 racket/list 16 racket/syntax 17 racket/contract 18 syntax/parse 19 syntax/id-set 20 syntax/free-vars 21 type-expander/expander 22 phc-toolkit/untyped 23 "fully-expanded-grammar-no-set.rkt")) 24 25 (version-case 26 [(version< (version) "6.90.0.29") 27 (begin)] 28 [else 29 (require racket/unsafe/undefined)]) 30 31 (unsafe-require/typed 32 "pure-unsafe.rkt" 33 [promise/pure/maybe-stateful? (→ Any Boolean : Promise)] 34 [promise/pure/stateless? (→ Any Boolean : Promise)] 35 [make-promise/pure/stateful (∀ (a) (→ (→ a) (Promise a)))] 36 [make-promise/pure/stateless (∀ (a) (→ (→ a) (Promise a)))] 37 [declared-stateful-pure-function? (→ Any Boolean)] 38 [declared-stateless-pure-function? (→ Any Boolean)] 39 [declared-stateful-pure-function (∀ (A) (→ A A))] 40 [declared-stateless-pure-function (∀ (A) (→ A A))]) 41 42 (unsafe-require/typed 43 racket/base 44 ;; The type of vector->list was fixed by PR #437, the unsafe-require/typed 45 ;; is left for compatibility with earlier versions. 46 [vector->list (∀ (a) (case→ (→ (Vectorof a) (Listof a)) 47 (→ VectorTop (Listof Any))))] 48 [struct-constructor-procedure? (→ Any Boolean)] 49 [struct-predicate-procedure? (→ Any Boolean)] 50 [struct-accessor-procedure? (→ Any Boolean)]) 51 52 (unsafe-require/typed racket/struct 53 [[struct->list unsafe-struct->list] 54 (→ Any (Listof Any))]) 55 56 (provide pure/stateful 57 pure/stateless 58 pure-thunk/stateful 59 pure-thunk/stateless 60 define-pure/stateful 61 define-pure/stateless 62 built-in-pure-functions-set 63 (for-syntax built-in-pure-functions-free-id-set) 64 promise/pure/maybe-stateful? 65 promise/pure/stateless? 66 immutable/stateful/c 67 immutable/stateless/c 68 unsafe-declare-pure/stateless 69 unsafe-declare-allowed-in-pure/stateful) 70 71 (define-for-syntax built-in-pure-functions-free-id-set 72 (immutable-free-id-set 73 (syntax->list 74 #'(+ - * / modulo add1 sub1 =;; … 75 eq? eqv? equal? ;; TODO: equal? can still cause problems if the 76 ;; struct's prop:equal+hash is effectful. 77 error 78 format values 79 promise/pure/maybe-stateful? promise/pure/stateless? 80 ;; Does not have a type yet: 81 ;; list* 82 null cons car cdr list list? pair? null? length reverse ;; … 83 void 84 vector-ref vector-immutable vector-length vector->list vector? ;; … 85 hash-ref hash->list hash? ;; … 86 set-member? set->list set? ;; … 87 ;; allow force, because we only allow capture of free variables 88 ;; containing pure stateless promises, which are therefore safe 89 ;; to force. 90 force 91 ;; … 92 )))) 93 94 (define-for-syntax (built-in-pure-function? id) 95 (define (empty-mpi? mpi) 96 (equal? (call-with-values (λ () (module-path-index-split mpi)) 97 list) 98 '(#f #f))) 99 (or (free-id-set-member? built-in-pure-functions-free-id-set id) 100 (let ([ib (identifier-binding id)]) 101 (match ib 102 ;; circumvent https://github.com/racket/racket/issues/1697 103 [(list* (? empty-mpi?) _) #f] 104 [(list* (app collapse-module-path-index 105 '(lib "racket/private/kw.rkt")) 106 'make-optional-keyword-procedure 107 _) 108 #t] 109 [_ #f])))) 110 111 (define-syntax (def-built-in-set stx) 112 (syntax-case stx () 113 [(_ name) 114 #`(define name 115 (seteq . #,(free-id-set->list built-in-pure-functions-free-id-set)))])) 116 117 (def-built-in-set built-in-pure-functions-set) 118 119 (begin 120 (define-for-syntax unsafe-pure-functions-free-id-set/stateless 121 (mutable-free-id-set)) 122 (: rw-unsafe-pure-functions-set/stateless (Boxof (Setof Procedure))) 123 (define rw-unsafe-pure-functions-set/stateless (box ((inst set Procedure)))) 124 (define (unsafe-pure-functions-set/stateless) 125 (unbox rw-unsafe-pure-functions-set/stateless)) 126 (define-syntax (unsafe-declare-pure/stateless stx) 127 (syntax-case stx () 128 [(_ fn) 129 (begin 130 (free-id-set-add! unsafe-pure-functions-free-id-set/stateless #'fn) 131 #'(set-box! rw-unsafe-pure-functions-set/stateless 132 (set-add (unbox rw-unsafe-pure-functions-set/stateless) 133 fn)))])) 134 (define-for-syntax (unsafe-pure-function?/stateless id) 135 (free-id-set-member? unsafe-pure-functions-free-id-set/stateless id))) 136 137 (begin 138 (define-for-syntax unsafe-allowed-functions-free-id-set/stateful 139 (mutable-free-id-set)) 140 (: rw-unsafe-allowed-functions-set/stateful (Boxof (Setof Procedure))) 141 (define rw-unsafe-allowed-functions-set/stateful (box ((inst set Procedure)))) 142 (define (unsafe-allowed-functions-set/stateful) 143 (unbox rw-unsafe-allowed-functions-set/stateful)) 144 (define-syntax (unsafe-declare-allowed-in-pure/stateful stx) 145 (syntax-case stx () 146 [(_ fn) 147 (identifier? #'fn) 148 (begin 149 (free-id-set-add! unsafe-allowed-functions-free-id-set/stateful #'fn) 150 #'(set-box! rw-unsafe-allowed-functions-set/stateful 151 (set-add (unbox rw-unsafe-allowed-functions-set/stateful) 152 fn)))])) 153 (define-for-syntax (unsafe-allowed-function?/stateful id) 154 (free-id-set-member? unsafe-allowed-functions-free-id-set/stateful id))) 155 156 (: check-immutable/error (→ Variable-Reference 157 (U 'stateful 'stateless) 158 (→ Any Boolean))) 159 (define ((check-immutable/error varref stateful/stateless) x) 160 (check-immutable! 161 x 162 varref 163 stateful/stateless 164 (λ () (error (~a "The " x " value was used within a free variable of a pure" 165 " expression or as the result of a pure thunk, but it is" 166 " not immutable."))) 167 (λ () (error (~a "The " x " value was used within a free variable of a pure" 168 " expression or as the result of a pure thunk, but I could" 169 " not verify that it is immutable."))))) 170 171 (: check-immutable! (→ Any 172 Variable-Reference 173 (U 'stateful 'stateless) 174 (→ Void) 175 (→ Void) 176 Boolean)) 177 (define (check-immutable! x varref stateful/stateless not-immutable other) 178 (define (recur y) 179 (check-immutable! y varref stateful/stateless not-immutable other)) 180 (define-syntax-rule (assert x p) 181 (if (p x) #t (begin (not-immutable) #f))) 182 (cond 183 ;; Primitives without recursion 184 [(null? x) #t] 185 [(boolean? x) #t] 186 [(number? x) #t] 187 [(symbol? x) #t] 188 ;; De facto immutable, with recursion 189 [(pair? x) (and (recur (car x)) 190 (recur (cdr x)))] 191 [(set? x) (recur (set->list x))] 192 ;; Might be immutable, with recursion 193 [(string? x) (assert x immutable?)] 194 [(bytes? x) (assert x immutable?)] 195 [(box? x) (and (assert x immutable?) 196 (recur x))] 197 [(vector? x) (assert x immutable?) 198 (recur (vector->list x))] 199 [(hash? x) (and (assert x immutable?) 200 (recur (hash->list x)))] 201 [(set? x) (recur (set->list x))] 202 ;; Structs: 203 [(struct? x) (and (struct-instance-is-immutable? x) 204 (recur (unsafe-struct->list x)))] 205 ;; Pure functions 206 [((if (eq? stateful/stateless 'stateful) 207 declared-stateful-pure-function? 208 declared-stateless-pure-function?) x) #t] 209 [(set-member? built-in-pure-functions-set x) #t] 210 [(set-member? (unsafe-pure-functions-set/stateless) x) #t] 211 [(and (eq? stateful/stateless 'stateful) 212 (set-member? (unsafe-allowed-functions-set/stateful) x)) #t] 213 ;; delay/pure is only used in a safe way, unless the user requires 214 ;; private files 215 [(eq? x make-promise/pure/stateful) #t] 216 [(eq? x make-promise/pure/stateless) #t] 217 ;; Pure promises 218 ;; We disallow (promise/pure/maybe-stateful? x) because if forced again, 219 ;; the outside code may have a handle into some mutable data that we then 220 ;; use. promise/pure/stateless? is fine. 221 [(promise/pure/stateless? x) #t] 222 ;; accept struct construtors only if we can guarantee that the struct is 223 ;; immutable (this means that the constructor's (object-name) must be 224 ;; either 'st or 'make-st, where st is the struct type's name. 225 [(immutable-struct-constructor? x varref) #t] 226 [(struct-predicate-procedure? x) #t] 227 [(struct-accessor-procedure? x) #t] 228 ;; To allow pure functions which return pure functions, we need to allow 229 ;; check-immutable/c itself 230 [(eq? x check-immutable/error) #t] 231 ;; racket/unsafe/undefined is used in the expanded code for functions with 232 ;; opetional arguments. We allow it here (for now), even though it is 233 ;; unsafe, because the user (or a library) would need to explicitly require 234 ;; it to cause problems. Otherwise, it will only appear in code generated by 235 ;; typed/racket. 236 [(version-case 237 [(version< (version) "6.90.0.29") #f] 238 [else (eq? x unsafe-undefined)]) 239 #t] 240 ;; Otherwise, fail early before mutation causes problems 241 [else (begin (other) #f)])) 242 243 (: immutable/stateful/c (→ Variable-Reference (→ Any Boolean))) 244 (define ((immutable/stateful/c varref) x) 245 (check-immutable! x varref 'stateful void void)) 246 247 (: immutable/stateless/c (→ Variable-Reference (→ Any Boolean))) 248 (define ((immutable/stateless/c varref) x) 249 (check-immutable! x varref 'stateless void void)) 250 251 (define-for-syntax (make-no-set!-transformer id [wrapper #f]) 252 (λ (stx) 253 (syntax-case stx () 254 [(set-id . rest) 255 (free-identifier=? #'set-id #'set!) 256 (raise-syntax-error 257 'pure 258 (format (string-append "set! cannot be used in a pure expression to" 259 " mutate the free identifier ~a") 260 (syntax-e id)) 261 stx 262 #'set-id)] 263 [self (identifier? #'self) (if wrapper #`(#,wrapper #,id) id)] 264 [(self . args) 265 (identifier? #'self) 266 (datum->syntax (syntax-local-identifier-as-binding #'self) 267 `(,(if wrapper #`(#,wrapper #,id) id) . ,#'args))]))) 268 269 (begin-for-syntax 270 (define/contract (pure-impl self fn-stx check-result? stateful/stateless-sym) 271 (-> syntax? syntax? (or/c #f 'check-result) (or/c 'stateful 'stateless) 272 syntax?) 273 274 (define/with-syntax fn fn-stx) 275 (define/with-syntax stateful/stateless stateful/stateless-sym) 276 277 (define/with-syntax fully-expanded+lifts 278 ;; TODO: stop on make-predicate (and remove those before free-vars, 279 ;; they are safe) 280 (local-expand/capture-lifts #'fn 'expression '())) 281 282 (define/with-syntax (fully-expanded (marked-as-unsafe ...)) 283 (syntax-case #'fully-expanded+lifts (begin) 284 [(begin single-expression) #'(single-expression ())] 285 [(begin lifted ... expression) 286 (for-each (λ (lifted1) 287 (syntax-case lifted1 (define-values 288 unsafe-pure-block/stateless 289 unsafe-operation-block/mutating) 290 [(define-values (_) 291 (unsafe-pure-block/stateless . rest)) 292 #t] 293 [(define-values (_) 294 (unsafe-operation-block/mutating . rest)) 295 (if (not (eq? stateful/stateless-sym 'stateful)) 296 (raise-syntax-error 297 'pure 298 (format 299 (string-append "unsafe-operation/mutating" 300 " disallowed within" 301 " pure/stateless:\n~a") 302 (syntax->datum lifted1)) 303 #'fn 304 lifted1) 305 #t)] 306 [_ 307 (raise-syntax-error 308 'pure 309 (format 310 (string-append "lifted expressions are disallowed" 311 " within pure/stateful, pure/stateless" 312 " and similar forms (for now):\n~a") 313 (syntax->datum lifted1)) 314 #'fn 315 lifted1)])) 316 (syntax->list #'(lifted ...))) 317 #'(expression (lifted ...))])) 318 319 (define marked-as-unsafe-ids 320 (immutable-free-id-set 321 (syntax-case #'(marked-as-unsafe ...) (define-values) 322 [((define-values (id ...) _expr) ...) 323 (syntax->list #'(id ... ...))]))) 324 325 (when (eq? stateful/stateless-sym 'stateless) 326 (disallow-set!-in-expression #'fully-expanded)) 327 328 (define/with-syntax (free …) 329 (filter-not (λ (x) 330 (or (built-in-pure-function? x) 331 (unsafe-pure-function?/stateless x) 332 (and (eq? stateful/stateless-sym 'stateful) 333 (unsafe-allowed-function?/stateful x)) 334 (free-id-set-member? marked-as-unsafe-ids x))) 335 (free-vars #'fully-expanded #:module-bound? #t))) 336 337 (define/with-syntax (cached …) (generate-temporaries #'(free …))) 338 339 (define/with-syntax varref (datum->syntax self `(#%variable-reference))) 340 341 #`(let () 342 marked-as-unsafe ... 343 (let ([free free] …) 344 ;; Prevent the mutation of the cached copy, by making it a macro which 345 ;; rejects uses as the target of a set! . 346 (let-syntax ([free (make-no-set!-transformer #'free)] …) 347 ;; The input should always be stateless 348 (assert free (check-immutable/error varref 'stateless)) 349 … 350 ;; The result must be pure too, otherwise it could (I 351 ;; suppose) cause problems with occurrence typing, if a 352 ;; copy is mutated but not the other, and TR still 353 ;; expects them to be equal? 354 ;; By construction, it should be immutable, except for functions 355 ;; (which can hold internal state), but TR won't assume that when 356 ;; called twice, the same function will return the same result. For 357 ;; extra security, the result is checked if #:check-result is 358 ;; specified. Note that when #:check-result is specified, the pure 359 ;; thunk cannot return functions. 360 #,(if check-result? 361 #'(λ () 362 (let ([result (fully-expanded)]) 363 ;; The output may be stateful 364 (assert result 365 (check-immutable/error varref 366 'stateful/stateless)) 367 result)) 368 #'fully-expanded)))))) 369 370 (define-syntax (pure/stateful stx) 371 (syntax-case stx () 372 [(self expr) (pure-impl #'self #'expr #f 'stateful)])) 373 374 (define-syntax (pure/stateless stx) 375 (syntax-case stx () 376 [(self expr) (pure-impl #'self #'expr #f 'stateless)])) 377 378 (define-syntax (pure-thunk/stateful stx) 379 (syntax-case stx () 380 [(self fn) (pure-impl #'self #'fn #f 'stateful)] 381 [(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateful)])) 382 383 (define-syntax (pure-thunk/stateless stx) 384 (syntax-case stx () 385 [(self fn) (pure-impl #'self #'fn #f 'stateless)] 386 [(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateless)]) 387 ) 388 389 (begin-for-syntax 390 (define-syntax-class (maybe-free-id=? other) 391 #:attributes () 392 (pattern self:id #:when (or (not other) 393 (free-identifier=? #'self other)))) 394 395 (define-syntax-class (name+args+body [other-name #f]) 396 (pattern ({~and {~optional {~seq #:∀ tvars}} {~seq fa …}} 397 ({~var name (maybe-free-id=? other-name)} . args) 398 . rest))) 399 (define-syntax-class def 400 (pattern {~and d {~or {~literal define} 401 {~literal te:define}}} 402 #:do [(record-disappeared-uses* #'d)]))) 403 404 (define-for-syntax ((define-pure/impl stateful/stateless-sym) stx) 405 (with-disappeared-uses 406 (syntax-parse stx 407 [{~or (self {~and whole-τ (CT:colon name/τ:id . self-τ)} 408 (:def . {~var || (name+args+body #'name/τ)})) 409 (self . {~and :name+args+body {~not ((:colon . _) . _)}})} 410 #:with lam (if (free-identifier=? (datum->syntax #'self 'λ) #'te:λ) 411 (datum->syntax #'here 'te:λ #'name) 412 (datum->syntax #'here 'λ #'name)) 413 #:with pure/? (if (eq? stateful/stateless-sym 'stateful) 414 #'pure/stateful 415 #'pure/stateless) 416 #:with declared-wrapper (if (eq? stateful/stateless-sym 'stateful) 417 #'declared-stateful-pure-function 418 #'declared-stateless-pure-function) 419 #:with unsafe-free-id-set 420 (if (eq? stateful/stateless-sym 'stateful) 421 #'unsafe-allowed-functions-free-id-set/stateful 422 #'unsafe-pure-functions-free-id-set/stateless) 423 #:with name-impl ((make-syntax-introducer) #'name) 424 (quasisyntax/top-loc this-syntax 425 (begin 426 #,@(when-attr CT #'{(CT name-impl . self-τ)}) 427 ;#,@(when-attr whole-τ #'{whole-τ}) ;; not needed. 428 (define-syntax name (make-no-set!-transformer #'name-impl)) 429 (define name-impl 430 (declared-wrapper 431 (pure/? 432 (lam fa … args . rest)))) 433 (define-syntax dummy 434 ;; Must happen after defining name-impl, so that the fresh 435 ;; definition is visible. Due to the way Racket handle intdef-ctx 436 ;; it will first run all the macro definitions, and then expand the 437 ;; contents of name-impl (so when expanding the pure/? code, 438 ;; the free-id-set will already be modified. 439 (free-id-set-add! unsafe-free-id-set #'name-impl))))]))) 440 441 (define-syntax define-pure/stateful (define-pure/impl 'stateful)) 442 (define-syntax define-pure/stateless (define-pure/impl 'stateless))