This repository has been archived on 2022-08-10. You can view files and clone it, but cannot push or open issues or pull requests.
chez-openbsd/s/cpvalid.ss
2022-07-29 15:12:07 +02:00

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)))))
)