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/cpcheck.ss
2022-07-29 15:12:07 +02:00

211 lines
8.8 KiB
Scheme

;;; cpcheck.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.
;;; cpcheck checks argument counts in calls to primitives and user-defined
;;; procedures, where it can recognize them. by running it after cp0, we
;;; catch more potentially incorrect calls, including calls to the record
;;; constructors and accessors constructed by cp0. running it after cp0 can
;;; also lead to bogus warnings on rare occasions, as in:
;;;
;;; (define (f b)
;;; (define h (lambda (b f) (if b (f 1) (f 1 2))))
;;; (if b
;;; (h b (lambda (x) x))
;;; (h b (lambda (x y) y))))
;;;
;;; where the calls (f 1) and (f 1 2) will be identified as having possible
;;; incorrect argument counts. it seems like a reasonable tradeoff.
(define $cpcheck
(let ()
(import (nanopass))
(include "base-lang.ss")
(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
(define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
(define maybe-remake-rtd
(lambda (rtd)
(if (eq? ($target-machine) (machine-type))
rtd
($remake-rtd rtd (let () (include "layout.ss") compute-field-offsets)))))
(define record-field-offset
(lambda (rtd index)
(let ([rtd (maybe-remake-rtd rtd)])
(fld-byte (list-ref (rtd-flds rtd) index)))))
(define-pass cpcheck : Lsrc (ir) -> Lsrc ()
(definitions
(define-record-type call-context
(nongenerative)
(sealed #t)
(fields cnt (mutable err))
(protocol
(lambda (new)
(lambda (cnt) (new cnt #f)))))
(define check!
(lambda (ctxt interface*)
(define interface-okay?
(lambda (interface* cnt)
(ormap
(lambda (interface)
(if (fx< interface 0)
(fx>= cnt (lognot interface))
(fx= cnt interface)))
interface*)))
(when ctxt
(unless (interface-okay? interface* (call-context-cnt ctxt))
(call-context-err-set! ctxt #t)))))
(define record-lambda!
(lambda (id val)
(unless (prelex-assigned id)
(nanopass-case (Lsrc Expr) val
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)
(prelex-operand-set! id interface*)]
[else (void)]))))
(define-syntax with-record-lambda
(syntax-rules ()
[(_ ids vals body)
(begin
(for-each record-lambda! ids vals)
(let ([x body])
(for-each (lambda (id) (prelex-operand-set! id #f)) ids)
x))]))
(with-output-language (Lsrc Expr)
(define build-sequence
(lambda (x* body)
(fold-left (lambda (body x) `(seq ,x ,body)) body x*)))
(define argcnt-error
(lambda (preinfo f args)
(let ([call (parameterize ([print-gensym #f] [print-level 3] [print-length 6])
(format "~s" (preinfo-sexpr preinfo)))])
`(seq ,f
,(build-sequence args
(cond
[(preinfo-src preinfo) =>
(lambda (src)
($source-warning 'compile src #t
"possible incorrect argument count in call ~a"
call)
`(call ,preinfo
,(lookup-primref 2 '$source-violation)
(quote #f)
(quote ,src)
(quote #t)
(quote "incorrect argument count in call ~a")
(quote ,call)))]
[else
`(call ,preinfo
,(lookup-primref 2 '$oops)
(quote #f)
(quote "incorrect argument count in call ~a")
(quote ,call))]))))))))
(Expr : Expr (ir [ctxt #f]) -> Expr ()
[(quote ,d) ir]
[(ref ,maybe-src ,x)
(cond
[(prelex-operand x) =>
(lambda (interface*)
(and (list? interface*)
(check! ctxt interface*)))])
`(ref ,maybe-src ,x)]
[(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
[(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
[(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
[(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(check! ctxt (list (length arg-type*)))
`(foreign (,conv* ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable (,conv* ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)]
[(call ,preinfo0
(case-lambda ,preinfo1
(clause (,x* ...) ,interface ,body)
,cl* ...)
,[e* #f -> e*] ...)
(guard (fx= (length e*) interface))
`(call ,preinfo0
(case-lambda ,preinfo1
(clause (,x* ...) ,interface
,(with-record-lambda x* e* (Expr body ctxt))))
,e* ...)]
[(call ,preinfo ,e ,[e* #f -> e*] ...)
(let ([sexpr (preinfo-sexpr preinfo)])
(define ugly-gensym? ; gensym w/no pretty name
(lambda (x)
(and (gensym? x)
(let ([name ($symbol-name x)])
(or (not (pair? name)) (not (cdr name)))))))
(if (and sexpr (and (pair? sexpr) (not (ugly-gensym? (car sexpr)))))
(let ([ctxt (make-call-context (length e*))])
(let ([e (Expr e ctxt)])
(if (call-context-err ctxt)
(argcnt-error preinfo e e*)
`(call ,preinfo ,e ,e* ...))))
`(call ,preinfo ,(Expr e #f) ,e* ...)))]
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* #f -> body*]) ...)
(check! ctxt interface*)
`(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...)]
[(letrec ([,x* ,e*] ...) ,body)
(with-record-lambda x* e*
`(letrec ([,x* ,(map (lambda (e) (Expr e #f)) e*)] ...)
,(Expr body ctxt)))]
[,pr (let ([arity (primref-arity pr)]) (when arity (check! ctxt arity))) pr]
[(record-ref ,rtd ,type ,index ,[e #f -> e])
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-ref)
(quote ,type) ,e (quote ,(record-field-offset rtd index)))]
[(record-set! ,rtd ,type ,index ,[e1 #f -> e1] ,[e2 #f -> e2])
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
(quote ,type) ,e1 (quote ,(record-field-offset rtd index)) ,e2)]
[(record ,rtd ,[rtd-expr #f -> rtd-expr] ,[e* #f -> e*] ...)
(let ([rtd (maybe-remake-rtd rtd)])
(let ([fld* (rtd-flds rtd)] [rec-t (make-prelex*)])
(safe-assert (fx= (length e*) (length fld*)))
(let ([filler* (fold-right
(lambda (fld e filler*)
(let ([type (fld-type fld)])
(if (eq? (filter-foreign-type type) 'scheme-object)
filler*
(cons
`(call ,(make-preinfo) ,(lookup-primref 3 '$object-set!)
(quote ,type) (ref #f ,rec-t) (quote ,(fld-byte fld)) ,e)
filler*))))
'() fld* e*)])
(if (null? filler*)
`(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr ,e* ...)
(begin
(set-prelex-referenced! rec-t #t)
(set-prelex-multiply-referenced! rec-t #t)
`(call ,(make-preinfo)
(case-lambda ,(make-preinfo-lambda)
(clause (,rec-t) 1 ,(build-sequence filler* `(ref #f ,rec-t))))
(call ,(make-preinfo) ,(lookup-primref 3 '$record) ,rtd-expr
,(map (lambda (arg) (cond [(eqv? arg 0) `(quote 0)] [else arg]))
(make-record-call-args fld* (rtd-size rtd) e*))
...)))))))]
[(cte-optimization-loc ,box ,[e #f -> e]) e]
[(immutable-list (,e* ...) ,[e]) e]
[(moi) ir]
[(pariah) ir]
[(profile ,src) ir]
[else (sorry! who "unhandled record ~s" ir)]))
(lambda (x) (cpcheck x))))