#lang typed/racket/base (require "immutable-struct-constructor.rkt" "pure-exception.rkt" racket/set racket/format racket/promise (only-in typed/racket/unsafe unsafe-require/typed) (prefix-in te: type-expander) phc-toolkit version-case (for-syntax (rename-in racket/base [... …]) racket/match syntax/modcollapse racket/list racket/syntax racket/contract syntax/parse syntax/id-set syntax/free-vars type-expander/expander phc-toolkit/untyped "fully-expanded-grammar-no-set.rkt")) (version-case [(version< (version) "6.90.0.29") (begin)] [else (require racket/unsafe/undefined)]) (unsafe-require/typed "pure-unsafe.rkt" [promise/pure/maybe-stateful? (→ Any Boolean : (Promise Any))] [promise/pure/stateless? (→ Any Boolean : (Promise Any))] [make-promise/pure/stateful (∀ (a) (→ (→ a) (Promise a)))] [make-promise/pure/stateless (∀ (a) (→ (→ a) (Promise a)))] [declared-stateful-pure-function? (→ Any Boolean)] [declared-stateless-pure-function? (→ Any Boolean)] [declared-stateful-pure-function (∀ (A) (→ A A))] [declared-stateless-pure-function (∀ (A) (→ A A))]) (unsafe-require/typed racket/base ;; The type of vector->list was fixed by PR #437, the unsafe-require/typed ;; is left for compatibility with earlier versions. [vector->list (∀ (a) (case→ (→ (Vectorof a) (Listof a)) (→ VectorTop (Listof Any))))] [struct-constructor-procedure? (→ Any Boolean)] [struct-predicate-procedure? (→ Any Boolean)] [struct-accessor-procedure? (→ Any Boolean)]) (unsafe-require/typed racket/struct [[struct->list unsafe-struct->list] (→ Any (Listof Any))]) (provide pure/stateful pure/stateless pure-thunk/stateful pure-thunk/stateless define-pure/stateful define-pure/stateless built-in-pure-functions-set (for-syntax built-in-pure-functions-free-id-set) promise/pure/maybe-stateful? promise/pure/stateless? immutable/stateful/c immutable/stateless/c unsafe-declare-pure/stateless unsafe-declare-allowed-in-pure/stateful) (define-for-syntax built-in-pure-functions-free-id-set (immutable-free-id-set (syntax->list #'(+ - * / modulo add1 sub1 =;; … eq? eqv? equal? ;; TODO: equal? can still cause problems if the ;; struct's prop:equal+hash is effectful. error format values promise/pure/maybe-stateful? promise/pure/stateless? ;; Does not have a type yet: ;; list* null cons car cdr list list? pair? null? length reverse ;; … void vector-ref vector-immutable vector-length vector->list vector? ;; … hash-ref hash->list hash? ;; … set-member? set->list set? ;; … ;; allow force, because we only allow capture of free variables ;; containing pure stateless promises, which are therefore safe ;; to force. force ;; … )))) (define-for-syntax (built-in-pure-function? id) (define (empty-mpi? mpi) (equal? (call-with-values (λ () (module-path-index-split mpi)) list) '(#f #f))) (or (free-id-set-member? built-in-pure-functions-free-id-set id) (let ([ib (identifier-binding id)]) (match ib ;; circumvent https://github.com/racket/racket/issues/1697 [(list* (? empty-mpi?) _) #f] [(list* (app collapse-module-path-index '(lib "racket/private/kw.rkt")) 'make-optional-keyword-procedure _) #t] [_ #f])))) (define-syntax (def-built-in-set stx) (syntax-case stx () [(_ name) #`(define name (seteq . #,(free-id-set->list built-in-pure-functions-free-id-set)))])) (def-built-in-set built-in-pure-functions-set) (begin (define-for-syntax unsafe-pure-functions-free-id-set/stateless (mutable-free-id-set)) (: rw-unsafe-pure-functions-set/stateless (Boxof (Setof Procedure))) (define rw-unsafe-pure-functions-set/stateless (box ((inst set Procedure)))) (define (unsafe-pure-functions-set/stateless) (unbox rw-unsafe-pure-functions-set/stateless)) (define-syntax (unsafe-declare-pure/stateless stx) (syntax-case stx () [(_ fn) (begin (free-id-set-add! unsafe-pure-functions-free-id-set/stateless #'fn) #'(set-box! rw-unsafe-pure-functions-set/stateless (set-add (unbox rw-unsafe-pure-functions-set/stateless) fn)))])) (define-for-syntax (unsafe-pure-function?/stateless id) (free-id-set-member? unsafe-pure-functions-free-id-set/stateless id))) (begin (define-for-syntax unsafe-allowed-functions-free-id-set/stateful (mutable-free-id-set)) (: rw-unsafe-allowed-functions-set/stateful (Boxof (Setof Procedure))) (define rw-unsafe-allowed-functions-set/stateful (box ((inst set Procedure)))) (define (unsafe-allowed-functions-set/stateful) (unbox rw-unsafe-allowed-functions-set/stateful)) (define-syntax (unsafe-declare-allowed-in-pure/stateful stx) (syntax-case stx () [(_ fn) (identifier? #'fn) (begin (free-id-set-add! unsafe-allowed-functions-free-id-set/stateful #'fn) #'(set-box! rw-unsafe-allowed-functions-set/stateful (set-add (unbox rw-unsafe-allowed-functions-set/stateful) fn)))])) (define-for-syntax (unsafe-allowed-function?/stateful id) (free-id-set-member? unsafe-allowed-functions-free-id-set/stateful id))) (: check-immutable/error (→ Variable-Reference (U 'stateful 'stateless) (→ Any Boolean))) (define ((check-immutable/error varref stateful/stateless) x) (check-immutable! x varref stateful/stateless (λ () (error (~a "The " x " value was used within a free variable of a pure" " expression or as the result of a pure thunk, but it is" " not immutable."))) (λ () (error (~a "The " x " value was used within a free variable of a pure" " expression or as the result of a pure thunk, but I could" " not verify that it is immutable."))))) (: check-immutable! (→ Any Variable-Reference (U 'stateful 'stateless) (→ Void) (→ Void) Boolean)) (define (check-immutable! x varref stateful/stateless not-immutable other) (define (recur y) (check-immutable! y varref stateful/stateless not-immutable other)) (define-syntax-rule (assert x p) (if (p x) #t (begin (not-immutable) #f))) (cond ;; Primitives without recursion [(null? x) #t] [(boolean? x) #t] [(number? x) #t] [(symbol? x) #t] ;; De facto immutable, with recursion [(pair? x) (and (recur (car x)) (recur (cdr x)))] [(set? x) (recur (set->list x))] ;; Might be immutable, with recursion [(string? x) (assert x immutable?)] [(bytes? x) (assert x immutable?)] [(box? x) (and (assert x immutable?) (recur x))] [(vector? x) (assert x immutable?) (recur (vector->list x))] [(hash? x) (and (assert x immutable?) (recur (hash->list x)))] [(set? x) (recur (set->list x))] ;; Structs: [(struct? x) (and (struct-instance-is-immutable? x) (recur (unsafe-struct->list x)))] ;; Pure functions [((if (eq? stateful/stateless 'stateful) declared-stateful-pure-function? declared-stateless-pure-function?) x) #t] [(set-member? built-in-pure-functions-set x) #t] [(set-member? (unsafe-pure-functions-set/stateless) x) #t] [(and (eq? stateful/stateless 'stateful) (set-member? (unsafe-allowed-functions-set/stateful) x)) #t] ;; delay/pure is only used in a safe way, unless the user requires ;; private files [(eq? x make-promise/pure/stateful) #t] [(eq? x make-promise/pure/stateless) #t] ;; Pure promises ;; We disallow (promise/pure/maybe-stateful? x) because if forced again, ;; the outside code may have a handle into some mutable data that we then ;; use. promise/pure/stateless? is fine. [(promise/pure/stateless? x) #t] ;; accept struct construtors only if we can guarantee that the struct is ;; immutable (this means that the constructor's (object-name) must be ;; either 'st or 'make-st, where st is the struct type's name. [(immutable-struct-constructor? x varref) #t] [(struct-predicate-procedure? x) #t] [(struct-accessor-procedure? x) #t] ;; To allow pure functions which return pure functions, we need to allow ;; check-immutable/c itself [(eq? x check-immutable/error) #t] ;; racket/unsafe/undefined is used in the expanded code for functions with ;; opetional arguments. We allow it here (for now), even though it is ;; unsafe, because the user (or a library) would need to explicitly require ;; it to cause problems. Otherwise, it will only appear in code generated by ;; typed/racket. [(version-case [(version< (version) "6.90.0.29") #f] [else (eq? x unsafe-undefined)]) #t] ;; Otherwise, fail early before mutation causes problems [else (begin (other) #f)])) (: immutable/stateful/c (→ Variable-Reference (→ Any Boolean))) (define ((immutable/stateful/c varref) x) (check-immutable! x varref 'stateful void void)) (: immutable/stateless/c (→ Variable-Reference (→ Any Boolean))) (define ((immutable/stateless/c varref) x) (check-immutable! x varref 'stateless void void)) (define-for-syntax (make-no-set!-transformer id [wrapper #f]) (λ (stx) (syntax-case stx () [(set-id . rest) (free-identifier=? #'set-id #'set!) (raise-syntax-error 'pure (format (string-append "set! cannot be used in a pure expression to" " mutate the free identifier ~a") (syntax-e id)) stx #'set-id)] [self (identifier? #'self) (if wrapper #`(#,wrapper #,id) id)] [(self . args) (identifier? #'self) (datum->syntax (syntax-local-identifier-as-binding #'self) `(,(if wrapper #`(#,wrapper #,id) id) . ,#'args))]))) (begin-for-syntax (define/contract (pure-impl self fn-stx check-result? stateful/stateless-sym) (-> syntax? syntax? (or/c #f 'check-result) (or/c 'stateful 'stateless) syntax?) (define/with-syntax fn fn-stx) (define/with-syntax stateful/stateless stateful/stateless-sym) (define/with-syntax fully-expanded+lifts ;; TODO: stop on make-predicate (and remove those before free-vars, ;; they are safe) (local-expand/capture-lifts #'fn 'expression '())) (define/with-syntax (fully-expanded (marked-as-unsafe ...)) (syntax-case #'fully-expanded+lifts (begin) [(begin single-expression) #'(single-expression ())] [(begin lifted ... expression) (for-each (λ (lifted1) (syntax-case lifted1 (define-values unsafe-pure-block/stateless unsafe-operation-block/mutating) [(define-values (_) (unsafe-pure-block/stateless . rest)) #t] [(define-values (_) (unsafe-operation-block/mutating . rest)) (if (not (eq? stateful/stateless-sym 'stateful)) (raise-syntax-error 'pure (format (string-append "unsafe-operation/mutating" " disallowed within" " pure/stateless:\n~a") (syntax->datum lifted1)) #'fn lifted1) #t)] [_ (raise-syntax-error 'pure (format (string-append "lifted expressions are disallowed" " within pure/stateful, pure/stateless" " and similar forms (for now):\n~a") (syntax->datum lifted1)) #'fn lifted1)])) (syntax->list #'(lifted ...))) #'(expression (lifted ...))])) (define marked-as-unsafe-ids (immutable-free-id-set (syntax-case #'(marked-as-unsafe ...) (define-values) [((define-values (id ...) _expr) ...) (syntax->list #'(id ... ...))]))) (when (eq? stateful/stateless-sym 'stateless) (disallow-set!-in-expression #'fully-expanded)) (define/with-syntax (free …) (filter-not (λ (x) (or (built-in-pure-function? x) (unsafe-pure-function?/stateless x) (and (eq? stateful/stateless-sym 'stateful) (unsafe-allowed-function?/stateful x)) (free-id-set-member? marked-as-unsafe-ids x))) (free-vars #'fully-expanded #:module-bound? #t))) (define/with-syntax (cached …) (generate-temporaries #'(free …))) (define/with-syntax varref (datum->syntax self `(#%variable-reference))) #`(let () marked-as-unsafe ... (let ([free free] …) ;; Prevent the mutation of the cached copy, by making it a macro which ;; rejects uses as the target of a set! . (let-syntax ([free (make-no-set!-transformer #'free)] …) ;; The input should always be stateless (assert free (check-immutable/error varref 'stateless)) … ;; The result must be pure too, otherwise it could (I ;; suppose) cause problems with occurrence typing, if a ;; copy is mutated but not the other, and TR still ;; expects them to be equal? ;; By construction, it should be immutable, except for functions ;; (which can hold internal state), but TR won't assume that when ;; called twice, the same function will return the same result. For ;; extra security, the result is checked if #:check-result is ;; specified. Note that when #:check-result is specified, the pure ;; thunk cannot return functions. #,(if check-result? #'(λ () (let ([result (fully-expanded)]) ;; The output may be stateful (assert result (check-immutable/error varref 'stateful/stateless)) result)) #'fully-expanded)))))) (define-syntax (pure/stateful stx) (syntax-case stx () [(self expr) (pure-impl #'self #'expr #f 'stateful)])) (define-syntax (pure/stateless stx) (syntax-case stx () [(self expr) (pure-impl #'self #'expr #f 'stateless)])) (define-syntax (pure-thunk/stateful stx) (syntax-case stx () [(self fn) (pure-impl #'self #'fn #f 'stateful)] [(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateful)])) (define-syntax (pure-thunk/stateless stx) (syntax-case stx () [(self fn) (pure-impl #'self #'fn #f 'stateless)] [(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateless)]) ) (begin-for-syntax (define-syntax-class (maybe-free-id=? other) #:attributes () (pattern self:id #:when (or (not other) (free-identifier=? #'self other)))) (define-syntax-class (name+args+body [other-name #f]) (pattern ({~and {~optional {~seq #:∀ tvars}} {~seq fa …}} ({~var name (maybe-free-id=? other-name)} . args) . rest))) (define-syntax-class def (pattern {~and d {~or {~literal define} {~literal te:define}}} #:do [(record-disappeared-uses* #'d)]))) (define-for-syntax ((define-pure/impl stateful/stateless-sym) stx) (with-disappeared-uses (syntax-parse stx [{~or (self {~and whole-τ (CT:colon name/τ:id . self-τ)} (:def . {~var || (name+args+body #'name/τ)})) (self . {~and :name+args+body {~not ((:colon . _) . _)}})} #:with lam (if (free-identifier=? (datum->syntax #'self 'λ) #'te:λ) (datum->syntax #'here 'te:λ #'name) (datum->syntax #'here 'λ #'name)) #:with pure/? (if (eq? stateful/stateless-sym 'stateful) #'pure/stateful #'pure/stateless) #:with declared-wrapper (if (eq? stateful/stateless-sym 'stateful) #'declared-stateful-pure-function #'declared-stateless-pure-function) #:with unsafe-free-id-set (if (eq? stateful/stateless-sym 'stateful) #'unsafe-allowed-functions-free-id-set/stateful #'unsafe-pure-functions-free-id-set/stateless) #:with name-impl ((make-syntax-introducer) #'name) (quasisyntax/top-loc this-syntax (begin #,@(when-attr CT #'{(CT name-impl . self-τ)}) ;#,@(when-attr whole-τ #'{whole-τ}) ;; not needed. (define-syntax name (make-no-set!-transformer #'name-impl)) (define name-impl (declared-wrapper (pure/? (lam fa … args . rest)))) (define-syntax dummy ;; Must happen after defining name-impl, so that the fresh ;; definition is visible. Due to the way Racket handle intdef-ctx ;; it will first run all the macro definitions, and then expand the ;; contents of name-impl (so when expanding the pure/? code, ;; the free-id-set will already be modified. (free-id-set-add! unsafe-free-id-set #'name-impl))))]))) (define-syntax define-pure/stateful (define-pure/impl 'stateful)) (define-syntax define-pure/stateless (define-pure/impl 'stateless))