565 lines
25 KiB
Scheme
565 lines
25 KiB
Scheme
|
;;; cpvalid.ss
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; see comments relating to both cpvalid and cpletrec at front of
|
||
|
|
;;; cpletrec.ss
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define undefined-variable-warnings
|
||
|
|
($make-thread-parameter #f (lambda (x) (and x #t))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(import (nanopass))
|
||
|
|
(include "base-lang.ss")
|
||
|
|
|
||
|
|
(define-pass cpvalid : Lsrc (x) -> Lsrc ()
|
||
|
|
(definitions
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
(define build-let
|
||
|
|
(lambda (ids vals body)
|
||
|
|
(if (null? ids)
|
||
|
|
body
|
||
|
|
`(call ,(make-preinfo)
|
||
|
|
(case-lambda ,(make-preinfo-lambda)
|
||
|
|
(clause (,ids ...) ,(length ids) ,body))
|
||
|
|
,vals ...))))
|
||
|
|
(define build-letrec
|
||
|
|
(lambda (ids vals body)
|
||
|
|
(if (null? ids)
|
||
|
|
; dropping source here; could attach to body or add source record
|
||
|
|
body
|
||
|
|
`(letrec ([,ids ,vals] ...) ,body))))
|
||
|
|
(define build-letrec*
|
||
|
|
(lambda (ids vals body)
|
||
|
|
(if (null? ids)
|
||
|
|
; dropping source here; could attach to body or add source record
|
||
|
|
body
|
||
|
|
`(letrec* ([,ids ,vals] ...) ,body)))))
|
||
|
|
|
||
|
|
(define-record-type proxy
|
||
|
|
(fields (mutable state))
|
||
|
|
(nongenerative)
|
||
|
|
(sealed #t)
|
||
|
|
(protocol
|
||
|
|
(lambda (new)
|
||
|
|
(lambda ()
|
||
|
|
(new 'protectable)))))
|
||
|
|
|
||
|
|
(define-syntax with-protected
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ p e)
|
||
|
|
(identifier? #'p)
|
||
|
|
(begin
|
||
|
|
(when p (proxy-state-set! p 'protected))
|
||
|
|
(let-values ([t (let ()
|
||
|
|
(define-syntax p
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-error x "can't reference proxy inside with-protected")))
|
||
|
|
e)])
|
||
|
|
(when p (proxy-state-set! p 'protectable))
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(define-syntax with-unprotected
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ p e)
|
||
|
|
(identifier? #'p)
|
||
|
|
(begin
|
||
|
|
(when p (proxy-state-set! p 'unprotected))
|
||
|
|
(let-values ([t (let ()
|
||
|
|
(define-syntax p
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-error x "can't reference proxy inside with-unprotected")))
|
||
|
|
e)])
|
||
|
|
(when p (proxy-state-set! p 'protectable))
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(module (with-info with-valid* with-valid** with-proxy with-proxy*
|
||
|
|
prelex-info-proxy prelex-info-valid-flag
|
||
|
|
set-prelex-info-unsafe! prelex-info-unsafe
|
||
|
|
set-prelex-info-referenced! prelex-info-referenced)
|
||
|
|
(define-record-type info
|
||
|
|
(fields (mutable proxy) (mutable unsafe) (mutable valid-flag) (mutable referenced))
|
||
|
|
(nongenerative)
|
||
|
|
(sealed #t)
|
||
|
|
(protocol
|
||
|
|
(lambda (new)
|
||
|
|
(lambda ()
|
||
|
|
(new #f #f #f #f)))))
|
||
|
|
|
||
|
|
(define-syntax with-info
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ ids-expr e)
|
||
|
|
(let ([ids ids-expr])
|
||
|
|
(for-each
|
||
|
|
(lambda (id)
|
||
|
|
(safe-assert (not (prelex-operand id)))
|
||
|
|
(prelex-operand-set! id (make-info)))
|
||
|
|
ids)
|
||
|
|
(let-values ([t e])
|
||
|
|
(for-each
|
||
|
|
(lambda (id)
|
||
|
|
(safe-assert (prelex-operand id))
|
||
|
|
(prelex-operand-set! id #f))
|
||
|
|
ids)
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(define set-prelex-info-valid-flag!
|
||
|
|
(lambda (id val)
|
||
|
|
(info-valid-flag-set! (prelex-operand id) val)))
|
||
|
|
|
||
|
|
(define prelex-info-valid-flag
|
||
|
|
(lambda (id)
|
||
|
|
(let ([info (prelex-operand id)])
|
||
|
|
(and info (info-valid-flag info)))))
|
||
|
|
|
||
|
|
(define-syntax with-valid*
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ valid-flag-expr ids-expr e)
|
||
|
|
(let ([valid-flag valid-flag-expr] [ids ids-expr])
|
||
|
|
(for-each (lambda (id) (set-prelex-info-valid-flag! id valid-flag)) ids)
|
||
|
|
(let-values ([t e])
|
||
|
|
(for-each (lambda (id) (set-prelex-info-valid-flag! id #f)) ids)
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(define-syntax with-valid**
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ valid-flags-expr ids-expr e)
|
||
|
|
(let ([valid-flags valid-flags-expr] [ids ids-expr])
|
||
|
|
(for-each (lambda (id vf) (set-prelex-info-valid-flag! id vf)) ids valid-flags)
|
||
|
|
(let-values ([t e])
|
||
|
|
(for-each (lambda (id) (set-prelex-info-valid-flag! id #f)) ids)
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(define-who set-prelex-info-proxy!
|
||
|
|
(lambda (id val)
|
||
|
|
(let ([info (prelex-operand id)])
|
||
|
|
(safe-assert info)
|
||
|
|
(info-proxy-set! info val))))
|
||
|
|
|
||
|
|
(define prelex-info-proxy
|
||
|
|
(lambda (id)
|
||
|
|
(let ([info (prelex-operand id)])
|
||
|
|
(and info (info-proxy info)))))
|
||
|
|
|
||
|
|
(define-syntax with-proxy
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ proxy-expr id-expr e)
|
||
|
|
(let ([proxy proxy-expr] [id id-expr])
|
||
|
|
(set-prelex-info-proxy! id proxy)
|
||
|
|
(let ([t e])
|
||
|
|
(set-prelex-info-proxy! id #f)
|
||
|
|
t))]))
|
||
|
|
|
||
|
|
(define-syntax with-proxy*
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ proxy-expr ids-expr e)
|
||
|
|
(let ([proxy proxy-expr] [ids ids-expr])
|
||
|
|
(for-each (lambda (id) (set-prelex-info-proxy! id proxy)) ids)
|
||
|
|
(let-values ([t e])
|
||
|
|
(for-each (lambda (id) (set-prelex-info-proxy! id #f)) ids)
|
||
|
|
(apply values t)))]))
|
||
|
|
|
||
|
|
(define set-prelex-info-unsafe!
|
||
|
|
(lambda (id val)
|
||
|
|
(info-unsafe-set! (prelex-operand id) val)))
|
||
|
|
|
||
|
|
(define prelex-info-unsafe
|
||
|
|
(lambda (id)
|
||
|
|
(info-unsafe (prelex-operand id))))
|
||
|
|
|
||
|
|
(define set-prelex-info-referenced!
|
||
|
|
(lambda (id val)
|
||
|
|
(let ([info (prelex-operand id)])
|
||
|
|
(when info (info-referenced-set! info val)))))
|
||
|
|
|
||
|
|
(define prelex-info-referenced
|
||
|
|
(lambda (id)
|
||
|
|
(info-referenced (prelex-operand id)))))
|
||
|
|
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
(define insert-valid-check
|
||
|
|
(lambda (what maybe-src id p x)
|
||
|
|
(if (and p (not (eq? (proxy-state p) 'protected)))
|
||
|
|
(let ([valid-flag (prelex-info-valid-flag id)])
|
||
|
|
(if valid-flag
|
||
|
|
(let ([name (prelex-name id)])
|
||
|
|
(let ([mesg (format "attempt to ~a undefined variable ~~s" what)])
|
||
|
|
(when (undefined-variable-warnings)
|
||
|
|
($source-warning #f maybe-src #t (format "possible ~a" mesg) name))
|
||
|
|
(if (prelex-referenced valid-flag)
|
||
|
|
(set-prelex-multiply-referenced! valid-flag #t)
|
||
|
|
(set-prelex-referenced! valid-flag #t))
|
||
|
|
`(seq
|
||
|
|
(if (ref #f ,valid-flag)
|
||
|
|
(quote ,(void))
|
||
|
|
(call ,(make-preinfo) ,(lookup-primref 2 '$source-violation)
|
||
|
|
(quote #f)
|
||
|
|
(quote ,maybe-src)
|
||
|
|
(quote #t)
|
||
|
|
(quote ,mesg)
|
||
|
|
(quote ,name)))
|
||
|
|
,x)))
|
||
|
|
x))
|
||
|
|
x))))
|
||
|
|
|
||
|
|
; wl = worklist
|
||
|
|
; dl = deferred list
|
||
|
|
(define (process-letrec-bindings cpvalid proxy proxy-ids ids vals unsafe* dl?)
|
||
|
|
(let f ([wl (map list ids vals unsafe*)] [dl '()] [oops #f])
|
||
|
|
(if (null? wl)
|
||
|
|
(if oops
|
||
|
|
(f dl '() #f)
|
||
|
|
(with-proxy* proxy proxy-ids
|
||
|
|
(map/ormap
|
||
|
|
(lambda (x)
|
||
|
|
(apply (lambda (id val unsafe)
|
||
|
|
(let-values ([(val dl?) (cpvalid val proxy dl?)])
|
||
|
|
(values (cons id val) dl?)))
|
||
|
|
x))
|
||
|
|
dl)))
|
||
|
|
(apply (lambda (id val unsafe)
|
||
|
|
(define update
|
||
|
|
(lambda (x)
|
||
|
|
(apply (lambda (id val unsafe)
|
||
|
|
(if (or unsafe (prelex-info-referenced id))
|
||
|
|
(begin (set-prelex-info-referenced! id #f)
|
||
|
|
(list id val #t))
|
||
|
|
x))
|
||
|
|
x)))
|
||
|
|
(if unsafe
|
||
|
|
(let ([val (with-unprotected proxy
|
||
|
|
(let ([proxy (make-proxy)])
|
||
|
|
(with-proxy* proxy proxy-ids
|
||
|
|
(first-value (cpvalid val proxy #f)))))])
|
||
|
|
(let-values ([(ls dl?) (f (map update (cdr wl)) (map update dl) #t)])
|
||
|
|
(values (cons (cons id val) ls) dl?)))
|
||
|
|
(f (cdr wl) (cons (car wl) dl) oops)))
|
||
|
|
(car wl)))))
|
||
|
|
|
||
|
|
(define map/ormap
|
||
|
|
(case-lambda
|
||
|
|
[(p ls)
|
||
|
|
(if (null? ls)
|
||
|
|
(values '() #f)
|
||
|
|
(let-values ([(x b1) (p (car ls))]
|
||
|
|
[(ls b2) (map/ormap p (cdr ls))])
|
||
|
|
(values (cons x ls) (or b1 b2))))]
|
||
|
|
[(p ls1 ls2)
|
||
|
|
(if (null? ls1)
|
||
|
|
(values '() #f)
|
||
|
|
(let-values ([(x b1) (p (car ls1) (car ls2))]
|
||
|
|
[(ls b2) (map/ormap p (cdr ls1) (cdr ls2))])
|
||
|
|
(values (cons x ls) (or b1 b2))))]))
|
||
|
|
|
||
|
|
(define deferred?
|
||
|
|
(lambda (x)
|
||
|
|
(nanopass-case (Lsrc Expr) x
|
||
|
|
[(cpvalid-defer ,e) #t]
|
||
|
|
[else #f])))
|
||
|
|
|
||
|
|
(with-output-language (Lsrc Expr)
|
||
|
|
(define defer-or-not
|
||
|
|
(lambda (dl? x)
|
||
|
|
(values
|
||
|
|
(if (and dl? (not (deferred? x)))
|
||
|
|
`(cpvalid-defer ,x)
|
||
|
|
x)
|
||
|
|
dl?))))
|
||
|
|
|
||
|
|
(define-syntax first-value
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ e) (let-values ([(x . r) e]) x)]))
|
||
|
|
|
||
|
|
(define undefer*
|
||
|
|
(lambda (ls proxy dl?)
|
||
|
|
(map/ormap
|
||
|
|
(lambda (x) (undefer x proxy dl?))
|
||
|
|
ls))))
|
||
|
|
|
||
|
|
(undefer : Expr (x proxy dl?) -> Expr (dl?)
|
||
|
|
[(cpvalid-defer ,[undefer-helper : e dl?]) (values e dl?)]
|
||
|
|
[else (values x #f)])
|
||
|
|
|
||
|
|
(undefer-helper : Expr (x proxy dl?) -> Expr (dl?)
|
||
|
|
[(ref ,maybe-src ,x) (values x #f)]
|
||
|
|
[(quote ,d) (values x #f)]
|
||
|
|
[,pr (values x #f)]
|
||
|
|
; recognize canonical form of a let after expansion
|
||
|
|
[(call ,preinfo0
|
||
|
|
(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,[undefer : body body-dl?]))
|
||
|
|
,e* ...)
|
||
|
|
(guard (fx= (length e*) interface))
|
||
|
|
(let-values ([(e* args-dl?) (undefer* e* proxy dl?)])
|
||
|
|
(defer-or-not (or body-dl? args-dl?)
|
||
|
|
`(call ,preinfo0
|
||
|
|
(case-lambda ,preinfo1
|
||
|
|
(clause (,x* ...) ,interface ,body))
|
||
|
|
,e* ...)))]
|
||
|
|
[(call ,preinfo ,[undefer : e fun-dl?] ,e* ...)
|
||
|
|
(let-values ([(e* args-dl?) (undefer* e* proxy dl?)])
|
||
|
|
(defer-or-not (or fun-dl? args-dl?)
|
||
|
|
`(call ,preinfo ,e ,e* ...)))]
|
||
|
|
[(if ,[undefer : e0 dl0?] ,[undefer : e1 dl1?] ,[undefer : e2 dl2?])
|
||
|
|
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
|
||
|
|
[(case-lambda ,preinfo ,cl* ...)
|
||
|
|
(cpvalid `(case-lambda ,preinfo ,cl* ...) proxy dl?)]
|
||
|
|
[(seq ,[undefer : e1 dl1?] ,[undefer : e2 dl2?])
|
||
|
|
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
|
||
|
|
[(set! ,maybe-src ,x ,[undefer : e dl?])
|
||
|
|
(defer-or-not dl? `(set! ,maybe-src ,x ,e))]
|
||
|
|
[(letrec ([,x* ,e*] ...) ,[undefer : body body-dl?])
|
||
|
|
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
|
||
|
|
(defer-or-not (or body-dl? vals-dl?)
|
||
|
|
`(letrec ([,x* ,e*] ...) ,body)))]
|
||
|
|
[(letrec* ([,x* ,e*] ...) ,[undefer : body body-dl?])
|
||
|
|
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
|
||
|
|
(defer-or-not (or body-dl? vals-dl?)
|
||
|
|
`(letrec* ([,x* ,e*] ...) ,body)))]
|
||
|
|
[(foreign (,conv* ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
|
||
|
|
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
|
||
|
|
[(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
|
||
|
|
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
|
||
|
|
[(cte-optimization-loc ,box ,[undefer : e dl?])
|
||
|
|
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
|
||
|
|
[(pariah) (values x #f)]
|
||
|
|
[(profile ,src) (values x #f)]
|
||
|
|
[(moi) (values x #f)]
|
||
|
|
[else (sorry! who "unexpected record ~s" x)])
|
||
|
|
|
||
|
|
(CaseLambdaClause : CaseLambdaClause (ir proxy) -> CaseLambdaClause ()
|
||
|
|
[(clause (,x* ...) ,interface ,body)
|
||
|
|
(let-values ([(body dl?) (with-protected proxy (cpvalid body #f #f))])
|
||
|
|
`(clause (,x* ...) ,interface ,body))])
|
||
|
|
|
||
|
|
(cpvalid : Expr (x proxy dl?) -> Expr (dl?)
|
||
|
|
[(ref ,maybe-src ,x)
|
||
|
|
(set-prelex-info-referenced! x #t)
|
||
|
|
(values
|
||
|
|
(let ([p (prelex-info-proxy x)])
|
||
|
|
; unsafe => x might be called. this can only happen if x has
|
||
|
|
; gotten into the unprotected state
|
||
|
|
(when (and p (eq? (proxy-state p) 'unprotected))
|
||
|
|
(set-prelex-info-unsafe! x #t))
|
||
|
|
(insert-valid-check "reference" maybe-src x p `(ref ,maybe-src ,x)))
|
||
|
|
#f)]
|
||
|
|
[,pr (values x #f)]
|
||
|
|
[(quote ,d) (values x #f)]
|
||
|
|
[(call ,preinfo ,pr ,e* ...)
|
||
|
|
(guard (all-set? (prim-mask (or proc discard)) (primref-flags pr)))
|
||
|
|
(let-values ([(e* dl?) (map/ormap (lambda (e) (cpvalid e proxy dl?)) e*)])
|
||
|
|
(defer-or-not dl? `(call ,preinfo ,pr ,e* ...)))]
|
||
|
|
; recognize canonical form of a let after expansion
|
||
|
|
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
|
||
|
|
(guard (fx= (length e*) interface))
|
||
|
|
(let ([proxy (or proxy (make-proxy))])
|
||
|
|
(with-info x*
|
||
|
|
(with-proxy* proxy x*
|
||
|
|
(let-values ([(body body-dl?) (cpvalid body proxy dl?)])
|
||
|
|
(let-values ([(e* dl?)
|
||
|
|
(map/ormap
|
||
|
|
(lambda (arg id)
|
||
|
|
(if (prelex-info-unsafe id)
|
||
|
|
(with-unprotected proxy (cpvalid arg #f #f))
|
||
|
|
(cpvalid arg proxy dl?)))
|
||
|
|
e* x*)])
|
||
|
|
(defer-or-not (or dl? body-dl?)
|
||
|
|
`(call ,preinfo0
|
||
|
|
(case-lambda ,preinfo1
|
||
|
|
(clause (,x* ...) ,interface ,body))
|
||
|
|
,e* ...)))))))]
|
||
|
|
[(call ,preinfo ,e ,e* ...)
|
||
|
|
(values
|
||
|
|
(with-unprotected proxy
|
||
|
|
`(call ,preinfo
|
||
|
|
,(first-value (cpvalid e #f #f))
|
||
|
|
,(map (lambda (x) (first-value (cpvalid x #f #f))) e*) ...))
|
||
|
|
#f)]
|
||
|
|
[(case-lambda ,preinfo ,cl* ...)
|
||
|
|
(if dl?
|
||
|
|
(values `(cpvalid-defer ,x) #t)
|
||
|
|
(values
|
||
|
|
`(case-lambda ,preinfo ,(map (lambda (cl) (CaseLambdaClause cl proxy)) cl*) ...)
|
||
|
|
#f))]
|
||
|
|
[(set! ,maybe-src ,x ,e)
|
||
|
|
(let-values ([(e dl?)
|
||
|
|
; rhs is unsafe only if x is referenced
|
||
|
|
(if (prelex-referenced x)
|
||
|
|
(with-unprotected proxy (cpvalid e #f #f))
|
||
|
|
(cpvalid e proxy dl?))])
|
||
|
|
(defer-or-not dl?
|
||
|
|
(insert-valid-check "assign" maybe-src x (prelex-info-proxy x)
|
||
|
|
(first-value
|
||
|
|
(defer-or-not dl?
|
||
|
|
`(set! ,maybe-src ,x ,e))))))]
|
||
|
|
[(letrec ([,x* ,e*] ...) ,body)
|
||
|
|
(with-info x*
|
||
|
|
(let*-values ([(proxy) (or proxy (make-proxy))]
|
||
|
|
[(valid-flag) (make-prelex* 'valid?)]
|
||
|
|
[(body body-dl?) (with-proxy* proxy x* (cpvalid body proxy dl?))]
|
||
|
|
[(unsafe*) (map prelex-info-unsafe x*)])
|
||
|
|
(for-each
|
||
|
|
(lambda (id)
|
||
|
|
(set-prelex-info-unsafe! id #f)
|
||
|
|
(set-prelex-info-referenced! id #f))
|
||
|
|
x*)
|
||
|
|
(let*-values ([(alist dl?) (with-valid* valid-flag x*
|
||
|
|
(process-letrec-bindings cpvalid proxy x* x* e* unsafe* dl?))]
|
||
|
|
[(e*) (map (lambda (id) (cdr (assq id alist))) x*)])
|
||
|
|
(defer-or-not (or dl? body-dl?)
|
||
|
|
(if (prelex-referenced valid-flag)
|
||
|
|
(begin
|
||
|
|
(set-prelex-assigned! valid-flag #t)
|
||
|
|
(build-let (list valid-flag) (list `(quote #f))
|
||
|
|
(first-value
|
||
|
|
(let-values ([(body body-dl?) (defer-or-not body-dl?
|
||
|
|
`(seq
|
||
|
|
(set! #f ,valid-flag (quote #t))
|
||
|
|
,body))])
|
||
|
|
(defer-or-not (or dl? body-dl?)
|
||
|
|
(build-letrec x* e* body))))))
|
||
|
|
(build-letrec x* e* body))))))]
|
||
|
|
[(letrec* ([,x* ,e*] ...) ,body)
|
||
|
|
; - we do unprotected parts of each rhs plus unsafe lambda pieces
|
||
|
|
; first and leave remaining lambda expressions to do later.
|
||
|
|
; - a full-blown flow analysis could be even nicer and even make it
|
||
|
|
; possible to detect references and assignments that are surely
|
||
|
|
; bad.
|
||
|
|
(with-info x*
|
||
|
|
(let*-values ([(proxy) (or proxy (make-proxy))]
|
||
|
|
[(valid-flags) (map (lambda (id) (make-prelex* 'valid?)) x*)]
|
||
|
|
[(body body-dl?) (with-proxy* proxy x* (cpvalid body proxy dl?))]
|
||
|
|
[(unsafe*) (map prelex-info-unsafe x*)])
|
||
|
|
(define-record-type welt (nongenerative) (sealed #t)
|
||
|
|
(fields id (mutable val) unsafe (mutable forbidden-ids) (mutable valid-flags)))
|
||
|
|
(define (make-welts x* e* unsafe* valid-flags)
|
||
|
|
(let f ([x* x*] [e* e*] [unsafe* unsafe*] [valid-flags valid-flags])
|
||
|
|
(if (null? x*)
|
||
|
|
'()
|
||
|
|
(cons (make-welt (car x*) (car e*) (car unsafe*) x* valid-flags)
|
||
|
|
(f (cdr x*) (cdr e*) (cdr unsafe*) (cdr valid-flags))))))
|
||
|
|
(define (process-ws w* d*)
|
||
|
|
(if (null? w*)
|
||
|
|
(process-letrec-bindings undefer proxy '()
|
||
|
|
(map welt-id d*)
|
||
|
|
(map welt-val d*)
|
||
|
|
(map welt-unsafe d*)
|
||
|
|
dl?)
|
||
|
|
(let ([w (car w*)])
|
||
|
|
(let ([id (welt-id w)]
|
||
|
|
[val (welt-val w)]
|
||
|
|
[unsafe (welt-unsafe w)]
|
||
|
|
[forbidden-ids (welt-forbidden-ids w)]
|
||
|
|
[valid-flags (welt-valid-flags w)])
|
||
|
|
(if (prelex-info-referenced id)
|
||
|
|
(let ([val (with-proxy* proxy forbidden-ids
|
||
|
|
(with-unprotected proxy
|
||
|
|
(with-valid** valid-flags forbidden-ids
|
||
|
|
(first-value
|
||
|
|
; could obviate this test with
|
||
|
|
; cpvalid-defer case in cpvalid
|
||
|
|
(if (deferred? val)
|
||
|
|
(undefer val #f #f)
|
||
|
|
(cpvalid val #f #f))))))])
|
||
|
|
(let-values ([(ls dl?) (process-ds (cdr w*) d* id (car valid-flags))])
|
||
|
|
(values (cons (cons id val) ls) dl?)))
|
||
|
|
(let-values ([(val dl?) (with-proxy* proxy forbidden-ids
|
||
|
|
(with-unprotected proxy
|
||
|
|
(with-valid** valid-flags forbidden-ids
|
||
|
|
(cpvalid val #f #t))))])
|
||
|
|
(if dl?
|
||
|
|
(begin
|
||
|
|
; deferred parts of rhs can reference own lhs, so remove it from forbidden list
|
||
|
|
(welt-val-set! w val)
|
||
|
|
(welt-forbidden-ids-set! w (cdr forbidden-ids))
|
||
|
|
(welt-valid-flags-set! w (cdr valid-flags))
|
||
|
|
(process-ds (cdr w*) (cons w d*) id (car valid-flags)))
|
||
|
|
(let-values ([(ls dl?) (process-ds (cdr w*) d* id (car valid-flags))])
|
||
|
|
(values (cons (cons id val) ls) dl?)))))))))
|
||
|
|
(define (process-ds w* d* okay-before-id okay-before-valid-flags)
|
||
|
|
; it's okay to reference any rhs before okay-before-id
|
||
|
|
; trim forbidden lists accordingly
|
||
|
|
(for-each
|
||
|
|
(lambda (w)
|
||
|
|
(cond
|
||
|
|
[(memq okay-before-id (welt-forbidden-ids w)) =>
|
||
|
|
(lambda (x*)
|
||
|
|
(welt-forbidden-ids-set! w x*)
|
||
|
|
(welt-valid-flags-set! w
|
||
|
|
(memq okay-before-valid-flags (welt-valid-flags w))))]))
|
||
|
|
d*)
|
||
|
|
(let f ([d* d*] [new-d* '()] [oops? #f])
|
||
|
|
(if (null? d*)
|
||
|
|
(if oops?
|
||
|
|
(f new-d* '() #f)
|
||
|
|
(process-ws w* new-d*))
|
||
|
|
(let* ([w (car d*)] [id (welt-id w)])
|
||
|
|
(if (prelex-info-referenced id)
|
||
|
|
(let ([val (with-proxy* proxy (welt-forbidden-ids w)
|
||
|
|
(with-unprotected proxy
|
||
|
|
(with-valid** (welt-valid-flags w) (welt-forbidden-ids w)
|
||
|
|
(first-value (undefer (welt-val w) #f #f)))))])
|
||
|
|
(let-values ([(ls dl?) (f (cdr d*) new-d* #t)])
|
||
|
|
(values (cons (cons id val) ls) dl?)))
|
||
|
|
(f (cdr d*) (cons w new-d*) oops?))))))
|
||
|
|
(for-each
|
||
|
|
(lambda (id)
|
||
|
|
(set-prelex-info-unsafe! id #f)
|
||
|
|
(set-prelex-info-referenced! id #f))
|
||
|
|
x*)
|
||
|
|
(let*-values ([(alist dl?) (process-ws (make-welts x* e* unsafe* valid-flags) '())]
|
||
|
|
[(e*) (map (lambda (id) (cdr (assq id alist))) x*)]
|
||
|
|
[(x* e* valid-flags)
|
||
|
|
(let f ([x* x*] [e* e*] [valid-flags valid-flags])
|
||
|
|
(if (null? x*)
|
||
|
|
(values '() '() '())
|
||
|
|
(let ([id (car x*)] [val (car e*)] [vf (car valid-flags)])
|
||
|
|
(let-values ([(x* e* valid-flags) (f (cdr x*) (cdr e*) (cdr valid-flags))])
|
||
|
|
(if (prelex-referenced vf)
|
||
|
|
(begin
|
||
|
|
(set-prelex-assigned! vf #t)
|
||
|
|
(values
|
||
|
|
(list* id (make-prelex* 'dummy) x*)
|
||
|
|
(list* val `(set! #f ,vf (quote #t)) e*)
|
||
|
|
(cons vf valid-flags)))
|
||
|
|
(values
|
||
|
|
(cons id x*)
|
||
|
|
(cons val e*)
|
||
|
|
valid-flags))))))])
|
||
|
|
(defer-or-not (or dl? body-dl?)
|
||
|
|
(build-let valid-flags (make-list (length valid-flags) `(quote #f))
|
||
|
|
(first-value
|
||
|
|
(defer-or-not (or dl? body-dl?)
|
||
|
|
(build-letrec* x* e* body))))))))]
|
||
|
|
[(if ,[cpvalid : e0 dl0?] ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
|
||
|
|
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
|
||
|
|
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
|
||
|
|
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
|
||
|
|
[(foreign (,conv* ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
|
||
|
|
(defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
|
||
|
|
[(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
|
||
|
|
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
|
||
|
|
[(cte-optimization-loc ,box ,[cpvalid : e dl?])
|
||
|
|
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
|
||
|
|
[(pariah) (values x #f)]
|
||
|
|
[(profile ,src) (values x #f)]
|
||
|
|
[(moi) (values x #f)]
|
||
|
|
[else (sorry! who "unexpected record ~s" x)])
|
||
|
|
(first-value (cpvalid x #f #f)))
|
||
|
|
|
||
|
|
(set! $cpvalid
|
||
|
|
(lambda (x)
|
||
|
|
(if (= (optimize-level) 3) x (cpvalid x)))))
|
||
|
|
)
|